clckwrks 0.21.1 → 0.22.0
raw patch · 8 files changed
+149/−21 lines, 8 filesdep ~aesondep ~attoparsecdep ~blaze-html
Dependency ranges changed: aeson, attoparsec, blaze-html, happstack-hsp, text
Files
- Clckwrks/Admin/Template.hs +43/−0
- Clckwrks/Monad.hs +26/−5
- Clckwrks/ProfileData/Acid.hs +3/−3
- Clckwrks/ProfileData/EditNewProfileData.hs +54/−0
- Clckwrks/ProfileData/Route.hs +14/−5
- Clckwrks/ProfileData/URL.hs +1/−0
- Clckwrks/Route.hs +1/−2
- clckwrks.cabal +7/−6
Clckwrks/Admin/Template.hs view
@@ -55,6 +55,49 @@ </body> </html>) +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 $+ <html>+ <head>+ <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap.min.css" rel="stylesheet" media="screen" />+ <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap-responsive.css" rel="stylesheet" />+ <link type="text/css" href="/static/admin.css" rel="stylesheet" />+ <script type="text/javascript" src="/jquery/jquery.js" ></script>+ <script type="text/javascript" src="/json2/json2.js" ></script>+ <script type="text/javascript" src="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/js/bootstrap.min.js" ></script>++ <title><% title %></title>+ <% headers %>+ </head>+ <body>+ <div class="navbar">+ <div class="navbar-inner">+ <div class="container-fluid">+ <div class="brand"><% siteName %></div>+ </div>+ </div>+ </div>++ <div class="container-fluid">+ <div class="row-fluid">+ <div class="span2">+-- <% sidebar %>+ </div>+ <div class="span10">+ <% body %>+ </div>+ </div>+ </div>+ </body>+ </html>)++ sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML
Clckwrks/Monad.hs view
@@ -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
Clckwrks/ProfileData/Acid.hs view
@@ -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)
+ Clckwrks/ProfileData/EditNewProfileData.hs view
@@ -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 ())+++
Clckwrks/ProfileData/Route.hs view
@@ -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
Clckwrks/ProfileData/URL.hs view
@@ -9,6 +9,7 @@ data ProfileDataURL = CreateNewProfileData | EditProfileData+ | EditNewProfileData | EditProfileDataFor UserId deriving (Eq, Ord, Read, Show, Data, Typeable)
Clckwrks/Route.hs view
@@ -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 ())--
clckwrks.cabal view
@@ -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,