diff --git a/Clckwrks/Admin/Template.hs b/Clckwrks/Admin/Template.hs --- a/Clckwrks/Admin/Template.hs +++ b/Clckwrks/Admin/Template.hs @@ -55,6 +55,49 @@ ) +emptyTemplate :: + ( Happstack m + , EmbedAsChild (ClckT url m) headers + , EmbedAsChild (ClckT url m) body + ) => String -> headers -> body -> ClckT url m Response +emptyTemplate title headers body = do + siteName <- (fromMaybe "Your Site") <$> query GetSiteName + toResponse <$> (unXMLGenT $ + + + + + + + + + + <% title %> + <% headers %> + + +
+
+
+
<% siteName %>
+
+
+
+ +
+
+
+-- <% sidebar %> +
+
+ <% body %> +
+
+
+ + ) + + sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML diff --git a/Clckwrks/Monad.hs b/Clckwrks/Monad.hs --- a/Clckwrks/Monad.hs +++ b/Clckwrks/Monad.hs @@ -43,6 +43,8 @@ , setUnique , requiresRole , requiresRole_ + , setRedirectCookie + , getRedirectCookie , getUserRoles , query , update @@ -65,7 +67,7 @@ import Clckwrks.Types (NamedLink(..), Prefix, Trust(Trusted)) import Clckwrks.Unauthorized (unauthorizedPage) import Clckwrks.URL (ClckURL(..)) -import Control.Applicative (Alternative, Applicative, (<$>), (<|>), many) +import Control.Applicative (Alternative, Applicative, (<$>), (<|>), many, optional) import Control.Monad (MonadPlus, foldM) import Control.Monad.State (MonadState, StateT, evalStateT, execStateT, get, mapStateT, modify, put, runStateT) import Control.Monad.Reader (MonadReader, ReaderT, mapReaderT) @@ -101,12 +103,17 @@ import Happstack.Auth (AuthProfileURL(..), AuthURL(..), AuthState, ProfileState, UserId) import qualified Happstack.Auth as Auth -import Happstack.Server (Happstack, ServerMonad(..), FilterMonad(..), WebMonad(..), Input, Request(..), Response, HasRqData(..), ServerPart, ServerPartT, UnWebT, internalServerError, mapServerPartT, escape, toResponse) +import Happstack.Server ( CookieLife(Session), Happstack, ServerMonad(..), FilterMonad(..) + , WebMonad(..), Input, Request(..), Response, HasRqData(..) + , ServerPart, ServerPartT, UnWebT, addCookie, expireCookie, escape + , internalServerError, lookCookieValue, mapServerPartT, mkCookie + , toResponse + ) import Happstack.Server.HSP.HTML () -- ToMessage XML instance import Happstack.Server.XMLGenT () -- instance Happstack XMLGenT import Happstack.Server.Internal.Monads (FilterFun) -- import HSP hiding (Request, escape) -import HSP.Google.Analytics (UACCT, analyticsAsync) +import HSP.Google.Analytics (UACCT, universalAnalytics) -- import HSP.ServerPartT () import HSP.XML import HSP.XMLGenerator @@ -648,6 +655,17 @@ -- * Require Role +setRedirectCookie :: (Happstack m) => + String -> m () +setRedirectCookie url = + addCookie Session (mkCookie "clckwrks-authenticate-redirect" url) + +getRedirectCookie :: (Happstack m) => + m (Maybe String) +getRedirectCookie = + do expireCookie "clckwrks-authenticate-redirect" + optional $ lookCookieValue "clckwrks-authenticate-redirect" + requiresRole_ :: (Happstack m) => (ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text) -> Set Role -> url -> ClckT u m url requiresRole_ showFn role url = ClckT $ RouteT $ \_ -> unRouteT (unClckT (requiresRole role url)) showFn @@ -656,7 +674,10 @@ requiresRole role url = do mu <- getUserId case mu of - Nothing -> escape $ seeOtherURL (Auth $ AuthURL A_Login) + Nothing -> + do rq <- askRq + escape $ do setRedirectCookie (rqUri rq ++ rqQuery rq) + seeOtherURL (Auth $ AuthURL A_Login) (Just uid) -> do r <- query (HasRole uid role) if r @@ -718,4 +739,4 @@ case muacct of Nothing -> return $ cdata "" (Just uacct) -> - analyticsAsync uacct + universalAnalytics uacct diff --git a/Clckwrks/ProfileData/Acid.hs b/Clckwrks/ProfileData/Acid.hs --- a/Clckwrks/ProfileData/Acid.hs +++ b/Clckwrks/ProfileData/Acid.hs @@ -97,13 +97,13 @@ -- | create the profile data, but only if it is missing newProfileData :: ProfileData - -> Update ProfileDataState ProfileData + -> Update ProfileDataState (ProfileData, Bool) newProfileData pd = do pds@(ProfileDataState {..}) <- get case getOne (profileData @= (dataFor pd)) of Nothing -> do put $ pds { profileData = updateIx (dataFor pd) pd profileData } - return pd - (Just pd') -> return pd' + return (pd, True) + (Just pd') -> return (pd', False) getUsername :: UserId -> Query ProfileDataState (Maybe Text) diff --git a/Clckwrks/ProfileData/EditNewProfileData.hs b/Clckwrks/ProfileData/EditNewProfileData.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/ProfileData/EditNewProfileData.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmFhsx2hs #-} +module Clckwrks.ProfileData.EditNewProfileData where + +import Clckwrks +import Clckwrks.Monad (getRedirectCookie) +import Clckwrks.Admin.Template (emptyTemplate) +import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr) +import Clckwrks.ProfileData.EditProfileData(profileDataFormlet) +import Data.Text (pack) +import qualified Data.Text as Text +import Data.Text.Lazy (Text) +import Data.Maybe (fromMaybe) +import Happstack.Auth (UserId) +import Text.Reform ((++>), mapView, transformEitherM) +import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs) +import Text.Reform.Happstack (reform) +import HSP.XMLGenerator +import HSP.XML + +-- FIXME: this currently uses the admin template. Which is sort of right, and sort of not. + +editNewProfileDataPage :: ProfileDataURL -> Clck ProfileDataURL Response +editNewProfileDataPage here = + do mUid <- getUserId + case mUid of + Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) + (Just uid) -> + do mpd <- query (GetProfileData uid) + case mpd of + Nothing -> + internalServerError $ toResponse $ "Missing profile data for " ++ show uid + + (Just pd) -> + do action <- showURL here + emptyTemplate "Edit Profile Data" () $ + <%> + <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> + + where + updated :: () -> Clck ProfileDataURL Response + updated () = + do mrc <- getRedirectCookie + case mrc of + Nothing -> + do mlr <- query GetLoginRedirect + case mlr of + Nothing -> seeOtherURL EditProfileData + (Just lr) -> seeOther lr (toResponse ()) + (Just u) -> + seeOther u (toResponse ()) + + + diff --git a/Clckwrks/ProfileData/Route.hs b/Clckwrks/ProfileData/Route.hs --- a/Clckwrks/ProfileData/Route.hs +++ b/Clckwrks/ProfileData/Route.hs @@ -4,6 +4,7 @@ import Clckwrks import Clckwrks.ProfileData.Acid import Clckwrks.ProfileData.EditProfileData (editProfileDataPage) +import Clckwrks.ProfileData.EditNewProfileData (editNewProfileDataPage) import Clckwrks.ProfileData.EditProfileDataFor (editProfileDataForPage) import Clckwrks.ProfileData.URL (ProfileDataURL(..)) import Clckwrks.ProfileData.Types @@ -22,13 +23,21 @@ do let profileData = emptyProfileData { dataFor = userId , roles = singleton Visitor } - update (NewProfileData profileData) - mRedirect <- query GetLoginRedirect - case mRedirect of - Nothing -> seeOtherURL EditProfileData - (Just url) -> seeOther url (toResponse ()) + (_, new) <- update (NewProfileData profileData) + if new + then seeOtherURL EditNewProfileData + else do mRedirect <- query GetLoginRedirect + case mRedirect of + (Just url) -> seeOther url (toResponse ()) + Nothing -> do + mRedirectCookie <- getRedirectCookie + case mRedirectCookie of + (Just u) -> seeOther u (toResponse ()) + Nothing -> seeOtherURL EditProfileData EditProfileData -> do editProfileDataPage url + EditNewProfileData -> + do editNewProfileDataPage url EditProfileDataFor u -> do editProfileDataForPage url u diff --git a/Clckwrks/ProfileData/URL.hs b/Clckwrks/ProfileData/URL.hs --- a/Clckwrks/ProfileData/URL.hs +++ b/Clckwrks/ProfileData/URL.hs @@ -9,6 +9,7 @@ data ProfileDataURL = CreateNewProfileData | EditProfileData + | EditNewProfileData | EditProfileDataFor UserId deriving (Eq, Ord, Read, Show, Data, Typeable) diff --git a/Clckwrks/Route.hs b/Clckwrks/Route.hs --- a/Clckwrks/Route.hs +++ b/Clckwrks/Route.hs @@ -30,6 +30,7 @@ Admin{} -> requiresRole (Set.singleton Administrator) url Auth{} -> return url Profile EditProfileData{} -> requiresRole (Set.fromList [Administrator, Visitor]) url + Profile EditNewProfileData{} -> requiresRole (Set.fromList [Administrator, Visitor]) url Profile EditProfileDataFor{} -> requiresRole (Set.fromList [Administrator]) url Profile CreateNewProfileData -> return url @@ -94,5 +95,3 @@ else do u <- rqUri <$> askRq let sslU = ((Text.unpack $ fromJust $ calcTLSBaseURI cc) ++ u) seeOther sslU (toResponse ()) - - diff --git a/clckwrks.cabal b/clckwrks.cabal --- a/clckwrks.cabal +++ b/clckwrks.cabal @@ -1,5 +1,5 @@ Name: clckwrks -Version: 0.21.1 +Version: 0.22.0 Synopsis: A secure, reliable content management system (CMS) and blogging platform Description: clckwrks (pronounced, clockworks) aims to compete directly with popular PHP-based blogging and CMS @@ -56,6 +56,7 @@ Clckwrks.ProfileData.Acid Clckwrks.ProfileData.API Clckwrks.ProfileData.EditProfileData + Clckwrks.ProfileData.EditNewProfileData Clckwrks.ProfileData.EditProfileDataFor Clckwrks.Route Clckwrks.Types @@ -68,16 +69,16 @@ Build-depends: acid-state >= 0.12 && < 0.13, - aeson >= 0.5 && < 0.7, - attoparsec == 0.10.*, + aeson >= 0.5 && < 0.8, + attoparsec >= 0.10 && < 0.12, base < 5, - blaze-html >= 0.5 && < 0.7, + blaze-html >= 0.5 && < 0.8, bytestring >= 0.9 && < 0.11, containers >= 0.4 && < 0.6, directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.4, happstack-authenticate == 0.10.*, - happstack-hsp == 7.2.*, + happstack-hsp == 7.3.*, happstack-server >= 7.0 && < 7.4, happstack-server-tls >= 7.1 && < 7.2, hsp >= 0.9 && < 0.11, @@ -96,7 +97,7 @@ safecopy >= 0.6, stm >= 2.2 && <2.5, tagsoup >= 0.12 && < 0.14, - text >= 0.11 && < 1.1, + text >= 0.11 && < 1.2, time >= 1.2 && <1.5, uuid >= 1.2 && < 1.4, unordered-containers >= 0.1 && < 0.3,