clckwrks 0.16.2 → 0.28.0.1
raw patch · 48 files changed
Files
- Clckwrks.hs +8/−8
- Clckwrks/Acid.hs +235/−29
- Clckwrks/Admin/Console.hs +5/−2
- Clckwrks/Admin/EditSettings.hs +112/−19
- Clckwrks/Admin/Route.hs +3/−0
- Clckwrks/Admin/SystemEmails.hs +104/−0
- Clckwrks/Admin/Template.hs +87/−19
- Clckwrks/Admin/URL.hs +2/−1
- Clckwrks/Authenticate/API.hs +57/−0
- Clckwrks/Authenticate/Monad.hs +34/−0
- Clckwrks/Authenticate/Page/AuthModes.hs +56/−0
- Clckwrks/Authenticate/Page/ChangePassword.hs +19/−0
- Clckwrks/Authenticate/Page/Login.hs +35/−0
- Clckwrks/Authenticate/Page/OpenIdRealm.hs +16/−0
- Clckwrks/Authenticate/Page/ResetPassword.hs +22/−0
- Clckwrks/Authenticate/Page/ViewUsers.hs +37/−0
- Clckwrks/Authenticate/Plugin.hs +146/−0
- Clckwrks/Authenticate/Plugin.hs-boot +13/−0
- Clckwrks/Authenticate/Route.hs +60/−0
- Clckwrks/Authenticate/URL.hs +22/−0
- Clckwrks/BasicTemplate.hs +7/−6
- Clckwrks/GetOpts.hs +32/−18
- Clckwrks/JS/ClckwrksApp.hs +49/−0
- Clckwrks/JS/Route.hs +13/−0
- Clckwrks/JS/URL.hs +14/−0
- Clckwrks/Markup/Markdown.hs +1/−0
- Clckwrks/Markup/Pandoc.hs +43/−0
- Clckwrks/Monad.hs +206/−132
- Clckwrks/NavBar/API.hs +5/−1
- Clckwrks/NavBar/EditNavBar.hs +106/−68
- Clckwrks/NavBar/Types.hs +12/−7
- Clckwrks/Plugin.hs +11/−10
- Clckwrks/ProfileData/API.hs +51/−14
- Clckwrks/ProfileData/Acid.hs +36/−93
- Clckwrks/ProfileData/EditNewProfileData.hs +60/−0
- Clckwrks/ProfileData/EditProfileData.hs +58/−41
- Clckwrks/ProfileData/EditProfileDataFor.hs +127/−38
- Clckwrks/ProfileData/Route.hs +14/−5
- Clckwrks/ProfileData/Types.hs +58/−21
- Clckwrks/ProfileData/URL.hs +5/−4
- Clckwrks/Route.hs +23/−24
- Clckwrks/Server.hs +141/−45
- Clckwrks/Types.hs +12/−4
- Clckwrks/URL.hs +21/−52
- Clckwrks/Unauthorized.hs +7/−4
- HSP/HTMLBuilder.hs +0/−156
- Setup.hs +1/−6
- clckwrks.cabal +81/−44
Clckwrks.hs view
@@ -1,19 +1,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies #-} module Clckwrks ( module Clckwrks.Acid--- , module Clckwrks.Menu.API+ , module Clckwrks.Authenticate.Plugin , module Clckwrks.Monad , module Clckwrks.ProfileData.API , module Clckwrks.ProfileData.Types+ , module Clckwrks.ProfileData.URL , module Clckwrks.Types , module Clckwrks.Unauthorized , module Clckwrks.URL+ , module Clckwrks.JS.URL , module Control.Applicative , module Control.Monad , module Control.Monad.Trans- , module Happstack.Auth- , module HSP- , module HSP.ServerPartT+ , module Data.UserId , module Happstack.Server , module Language.Javascript.JMacro , module Web.Routes@@ -21,22 +21,22 @@ ) where import Clckwrks.Acid+import Clckwrks.Authenticate.Plugin (getUserId) import Clckwrks.Admin.URL--- import Clckwrks.Menu.API+import Clckwrks.JS.URL import Clckwrks.Monad import Clckwrks.ProfileData.API import Clckwrks.ProfileData.Types+import Clckwrks.ProfileData.URL import Clckwrks.Types import Clckwrks.Unauthorized import Clckwrks.URL import Control.Applicative import Control.Monad import Control.Monad.Trans-import Happstack.Auth (UserId(..))+import Data.UserId (UserId(..)) import Happstack.Server import Happstack.Server.HSP.HTML-import HSP hiding (Request, escape)-import HSP.ServerPartT import Language.Javascript.JMacro (JExpr(..), JMacro(..), JStat(..), JType(..), JVal(..), Ident(..), toJExpr, jmacro, jmacroE) import Web.Routes hiding (nestURL) import Web.Routes.XMLGenT ()
Clckwrks/Acid.hs view
@@ -1,25 +1,34 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} module Clckwrks.Acid where -import Clckwrks.NavBar.Acid (NavBarState , initialNavBarState)+import Clckwrks.NavBar.Acid (NavBarState , initialNavBarState) import Clckwrks.ProfileData.Acid (ProfileDataState, initialProfileDataState) import Clckwrks.Types (UUID) import Clckwrks.URL (ClckURL) import Control.Applicative ((<$>)) import Control.Exception (bracket, catch, throw)+import Control.Lens ((?=), (.=), (^.), (.~), makeLenses, view, set)+import Control.Lens.At (IxValue(..), Ixed(..), Index(..), At(at)) import Control.Concurrent (killThread, forkIO) import Control.Monad.Reader (ask)-import Control.Monad.State (modify)-import Data.Acid (AcidState, Query, Update, makeAcidic)-import Data.Acid.Local (openLocalStateFrom, createArchive, createCheckpointAndClose)-import Data.Acid.Remote (acidServer)+import Control.Monad.State (modify, put)+import Data.Acid (AcidState, Query, Update, createArchive, makeAcidic)+import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose)+#if MIN_VERSION_acid_state (0,16,0)+import Data.Acid.Remote (acidServerSockAddr, skipAuthenticationCheck)+import Data.Int (Int64)+import Network.Socket (SockAddr(SockAddrUnix))+#else+import Data.Acid.Remote (acidServer, skipAuthenticationCheck)+import Network (PortID(UnixSocket))+#endif import Data.Data (Data, Typeable) import Data.Maybe (fromMaybe)-import Data.SafeCopy (base, deriveSafeCopy)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.Text (Text)-import Happstack.Auth.Core.Auth (AuthState , initialAuthState)-import Happstack.Auth.Core.Profile (ProfileState , initialProfileState)-import Network (PortID(UnixSocket))+import qualified Data.Text as Text+import Happstack.Authenticate.Core (AuthenticateState, SimpleAddress(..))+import Happstack.Authenticate.Password.Core (PasswordState) import Prelude hiding (catch) import System.Directory (removeFile) import System.FilePath ((</>))@@ -29,48 +38,232 @@ -- | 'CoreState' holds some values that are required by the core -- itself, or which are useful enough to be shared with numerous -- plugins/themes.+data CoreState_v0 = CoreState_v0+ { coreUACCT_v0 :: Maybe UACCT -- ^ Google Account UAACT+ , coreRootRedirect_v0 :: Maybe Text+ }+ deriving (Eq, Data, Typeable, Show)+$(deriveSafeCopy 0 'base ''CoreState_v0)++-- | 'CoreState' holds some values that are required by the core+-- itself, or which are useful enough to be shared with numerous+-- plugins/themes.+data CoreState_1 = CoreState_1+ { coreSiteName_1 :: Maybe Text+ , coreUACCT_1 :: Maybe UACCT -- ^ Google Account UAACT+ , coreRootRedirect_1 :: Maybe Text+ , coreLoginRedirect_1 :: Maybe Text++ }+ deriving (Eq, Data, Typeable, Show)++instance Migrate CoreState_1 where+ type MigrateFrom CoreState_1 = CoreState_v0+ migrate (CoreState_v0 ua rr) = CoreState_1 Nothing ua rr Nothing++$(deriveSafeCopy 1 'extension ''CoreState_1)++++-- | 'CoreState' holds some values that are required by the core+-- itself, or which are useful enough to be shared with numerous+-- plugins/themes.+data CoreState_2 = CoreState_2+ { _coreSiteName_2 :: Maybe Text+ , _coreUACCT_2 :: Maybe UACCT -- ^ Google Account UAACT+ , _coreRootRedirect_2 :: Maybe Text+ , _coreLoginRedirect_2 :: Maybe Text+ , _coreFromAddress_2 :: Maybe SimpleAddress+ , _coreReplyToAddress_2 :: Maybe SimpleAddress+ , _coreSendmailPath_2 :: Maybe FilePath+ , _coreEnableOpenId_2 :: Bool -- ^ allow OpenId authentication+ }+ deriving (Eq, Data, Typeable, Show)+$(deriveSafeCopy 2 'extension ''CoreState_2)++instance Migrate CoreState_2 where+ type MigrateFrom CoreState_2 = CoreState_1+ migrate (CoreState_1 sn ua rr lr) = CoreState_2 sn ua rr lr Nothing Nothing Nothing True++-- | 'CoreState' holds some values that are required by the core+-- itself, or which are useful enough to be shared with numerous+-- plugins/themes.+data CoreState_3 = CoreState_3+ { _coreSiteName_3 :: Maybe Text+ , _coreUACCT_3 :: Maybe UACCT -- ^ Google Account UAACT+ , _coreRootRedirect_3 :: Maybe Text+ , _coreLoginRedirect_3 :: Maybe Text+ , _coreFromAddress_3 :: Maybe SimpleAddress+ , _coreReplyToAddress_3 :: Maybe SimpleAddress+ , _coreSendmailPath_3 :: Maybe FilePath+ , _coreEnableOpenId_3 :: Bool -- ^ allow OpenId authentication+ , _coreBodyPolicy_3 :: (FilePath, Int64, Int64, Int64) -- ^ (temp directory for uploads, maxDisk, maxRAM, maxHeader)+ }+ deriving (Eq, Data, Typeable, Show)+$(deriveSafeCopy 3 'extension ''CoreState_3)++instance Migrate CoreState_3 where+ type MigrateFrom CoreState_3 = CoreState_2+ migrate (CoreState_2 sn ua rr lr fa rta smp eo) = CoreState_3 sn ua rr lr fa rta smp eo ("/tmp/", (10 * 10^6), (1 * 10^6), (1 * 10^6))++-- | 'CoreState' holds some values that are required by the core+-- itself, or which are useful enough to be shared with numerous+-- plugins/themes. data CoreState = CoreState- { coreUACCT :: Maybe UACCT -- ^ Google Account UAACT- , coreRootRedirect :: Maybe Text+ { _coreSiteName :: Maybe Text+ , _coreUACCT :: Maybe UACCT -- ^ Google Account UAACT+ , _coreRootRedirect :: Maybe Text+ , _coreLoginRedirect :: Maybe Text+ , _coreBackToSiteRedirect :: Text -- ^ where 'Back To <sitename>' link in settings panel should go+ , _coreFromAddress :: Maybe SimpleAddress+ , _coreReplyToAddress :: Maybe SimpleAddress+ , _coreSendmailPath :: Maybe FilePath+ , _coreEnableOpenId :: Bool -- ^ allow OpenId authentication+ , _coreBodyPolicy :: (FilePath, Int64, Int64, Int64) -- ^ (temp directory for uploads, maxDisk, maxRAM, maxHeader) } deriving (Eq, Data, Typeable, Show)-$(deriveSafeCopy 0 'base ''CoreState) +instance Migrate CoreState where+ type MigrateFrom CoreState = CoreState_3+ migrate (CoreState_3 sn ua rr lr fa rta smp eo bp) = CoreState sn ua rr lr (Text.pack "/") fa rta smp eo bp++$(deriveSafeCopy 4 'extension ''CoreState)++makeLenses ''CoreState++ initialCoreState :: CoreState initialCoreState = CoreState- { coreUACCT = Nothing- , coreRootRedirect = Nothing+ { _coreSiteName = Nothing+ , _coreUACCT = Nothing+ , _coreRootRedirect = Nothing+ , _coreLoginRedirect = Nothing+ , _coreBackToSiteRedirect = (Text.pack "/")+ , _coreFromAddress = Nothing+ , _coreReplyToAddress = Nothing+ , _coreSendmailPath = Nothing+ , _coreEnableOpenId = True+ , _coreBodyPolicy = ("/tmp/", (10 * 10^6), (1 * 10^6), (1 * 10^6)) } +-- | get the site name+getSiteName :: Query CoreState (Maybe Text)+getSiteName = view coreSiteName++-- | set the site name+setSiteName :: Maybe Text -> Update CoreState ()+setSiteName name = coreSiteName .= name+ -- | get the 'UACCT' for Google Analytics getUACCT :: Query CoreState (Maybe UACCT)-getUACCT = coreUACCT <$> ask+getUACCT = view coreUACCT -- | set the 'UACCT' for Google Analytics setUACCT :: Maybe UACCT -> Update CoreState ()-setUACCT mua = modify $ \cs -> cs { coreUACCT = mua }+setUACCT mua = coreUACCT .= mua -- | get the path that @/@ should redirect to getRootRedirect :: Query CoreState (Maybe Text)-getRootRedirect = coreRootRedirect <$> ask+getRootRedirect = view coreRootRedirect +-- | get the path that 'Back To Site' should go to+getBackToSiteRedirect :: Query CoreState Text+getBackToSiteRedirect = view coreBackToSiteRedirect++-- | set the path that 'Back To Site' should go to+setBackToSiteRedirect :: Text -> Update CoreState ()+setBackToSiteRedirect path = coreBackToSiteRedirect .= path+ -- | set the path that @/@ should redirect to setRootRedirect :: Maybe Text -> Update CoreState ()-setRootRedirect path = modify $ \cs -> cs { coreRootRedirect = path }+setRootRedirect path = coreRootRedirect .= path +-- | get the 'BodyPolicy' data for requests which can have bodies+getBodyPolicy :: Query CoreState (FilePath, Int64, Int64, Int64)+getBodyPolicy = view coreBodyPolicy++-- | set the 'BodyPolicy' data for requests which can have bodies+setBodyPolicy :: (FilePath, Int64, Int64, Int64) -> Update CoreState ()+setBodyPolicy bp = coreBodyPolicy .= bp++-- | get the path that we should redirect to after login+getLoginRedirect :: Query CoreState (Maybe Text)+getLoginRedirect = view coreLoginRedirect++-- | set the path that we should redirect to after login+setLoginRedirect :: Maybe Text -> Update CoreState ()+setLoginRedirect path = coreLoginRedirect .= path++-- | get the From: address for system emails+getFromAddress :: Query CoreState (Maybe SimpleAddress)+getFromAddress = view coreFromAddress++-- | get the From: address for system emails+setFromAddress :: Maybe SimpleAddress -> Update CoreState ()+setFromAddress addr = coreFromAddress .= addr++-- | get the Reply-To: address for system emails+getReplyToAddress :: Query CoreState (Maybe SimpleAddress)+getReplyToAddress = view coreReplyToAddress++-- | get the Reply-To: address for system emails+setReplyToAddress :: Maybe SimpleAddress -> Update CoreState ()+setReplyToAddress addr = coreReplyToAddress .= addr++-- | get the path to the sendmail executable+getSendmailPath :: Query CoreState (Maybe FilePath)+getSendmailPath = view coreSendmailPath++-- | set the path to the sendmail executable+setSendmailPath :: Maybe FilePath -> Update CoreState ()+setSendmailPath path = coreSendmailPath .= path++-- | get the status of enabling OpenId+getEnableOpenId :: Query CoreState Bool+getEnableOpenId = view coreEnableOpenId++-- | set the status of enabling OpenId+setEnableOpenId :: Bool -> Update CoreState ()+setEnableOpenId b = coreEnableOpenId .= b++-- | get the entire 'CoreState'+getCoreState :: Query CoreState CoreState+getCoreState = ask++-- | set the entire 'CoreState'+setCoreState :: CoreState -> Update CoreState ()+setCoreState = put+ $(makeAcidic ''CoreState [ 'getUACCT , 'setUACCT , 'getRootRedirect , 'setRootRedirect+ , 'getBackToSiteRedirect+ , 'setBackToSiteRedirect+ , 'getLoginRedirect+ , 'setLoginRedirect+ , 'getBodyPolicy+ , 'setBodyPolicy+ , 'getSiteName+ , 'setSiteName+ , 'getFromAddress+ , 'setFromAddress+ , 'getReplyToAddress+ , 'setReplyToAddress+ , 'getSendmailPath+ , 'setSendmailPath+ , 'setEnableOpenId+ , 'getEnableOpenId+ , 'getCoreState+ , 'setCoreState ]) data Acid = Acid- { acidAuth :: AcidState AuthState- , acidProfile :: AcidState ProfileState- , acidProfileData :: AcidState ProfileDataState- , acidCore :: AcidState CoreState- , acidNavBar :: AcidState NavBarState+ { -- acidAuthenticate :: AcidState AuthenticateState+ acidProfileData :: AcidState ProfileDataState+ , acidCore :: AcidState CoreState+ , acidNavBar :: AcidState NavBarState } class GetAcidState m st where@@ -79,14 +272,27 @@ withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a withAcid mBasePath f = let basePath = fromMaybe "_state" mBasePath in- bracket (openLocalStateFrom (basePath </> "auth") initialAuthState) (createArchiveCheckpointAndClose) $ \auth ->- bracket (openLocalStateFrom (basePath </> "profile") initialProfileState) (createArchiveCheckpointAndClose) $ \profile ->- bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createArchiveCheckpointAndClose) $ \profileData ->+ -- open acid-state databases bracket (openLocalStateFrom (basePath </> "core") initialCoreState) (createArchiveCheckpointAndClose) $ \core ->+ bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createArchiveCheckpointAndClose) $ \profileData -> bracket (openLocalStateFrom (basePath </> "navBar") initialNavBarState) (createArchiveCheckpointAndClose) $ \navBar ->- bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServer profileData (UnixSocket $ basePath </> "profileData_socket")))+ -- create sockets to allow `clckwrks-cli` to talk to the databases+#if MIN_VERSION_acid_state (0,16,0)+ bracket (forkIO (tryRemoveFile (basePath </> "core_socket") >> acidServerSockAddr skipAuthenticationCheck (SockAddrUnix $ basePath </> "core_socket") profileData))+ (\tid -> killThread tid >> tryRemoveFile (basePath </> "core_socket")) $ const $++#else+ bracket (forkIO (tryRemoveFile (basePath </> "core_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "core_socket") profileData))+ (\tid -> killThread tid >> tryRemoveFile (basePath </> "core_socket")) $ const $+#endif+#if MIN_VERSION_acid_state (0,16,0)+ bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServerSockAddr skipAuthenticationCheck (SockAddrUnix $ basePath </> "profileData_socket") profileData)) (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket"))- (const $ f (Acid auth profile profileData core navBar))+#else+ bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "profileData_socket") profileData))+ (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket"))+#endif+ (const $ f (Acid profileData core navBar)) where tryRemoveFile fp = removeFile fp `catch` (\e -> if isDoesNotExistError e then return () else throw e) createArchiveCheckpointAndClose acid =
Clckwrks/Admin/Console.hs view
@@ -1,9 +1,12 @@-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.Console where import Clckwrks (AdminURL(..), Clck, Response) import Clckwrks.Admin.Template (template)-import HSP+import Data.Text.Lazy (Text)+import HSP.XMLGenerator+import HSP.XML consolePage :: Clck AdminURL Response consolePage =
Clckwrks/Admin/EditSettings.hs view
@@ -1,38 +1,132 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.EditSettings where -import Clckwrks-import Clckwrks.Acid (GetUACCT(..), SetUACCT(..))-import Clckwrks.Admin.Template (template)+import Clckwrks hiding (transform)+import Clckwrks.Acid (GetUACCT(..), SetUACCT(..), coreSiteName, coreUACCT, coreRootRedirect, coreLoginRedirect, coreBackToSiteRedirect)+import Clckwrks.Admin.Template (template)+import Control.Lens ((&), (.~))+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+ -- import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..))-import HSP.Google.Analytics (UACCT(..))+import HSP.Google.Analytics (UACCT(..))+import HSP.XMLGenerator+import HSP.XML (fromStringLit)+import Numeric (readDec) import Text.Reform import Text.Reform.Happstack-import Text.Reform.HSP.String+import Text.Reform.HSP.Text editSettings :: ClckURL -> Clck ClckURL Response editSettings here =- do muacct <- query $ GetUACCT+ do coreState <- query $ GetCoreState action <- showURL here template "Edit Settings" () $ <%>- <% reform (form action) "ss" updateSettings Nothing (editSettingsForm muacct) %>+ <% reform (form action) "ss" updateSettings Nothing (editSettingsForm coreState) %> </%> where- updateSettings :: Maybe UACCT -> Clck ClckURL Response- updateSettings muacct =- do update (SetUACCT muacct)- seeOtherURL (Admin Console)+ updateSettings :: CoreState -> Clck ClckURL Response+ updateSettings coreState =+ do update (SetCoreState coreState)+ seeOtherURL here -editSettingsForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT)-editSettingsForm muacct =+editSettingsForm :: CoreState -> ClckForm ClckURL CoreState+editSettingsForm c@CoreState{..} = divHorizontal $ fieldset $+ (modifyCoreState <$>+ (divControlGroup $+ (labelText "site name" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (fromMaybe mempty _coreSiteName)) `transformEither` toMaybe)))++ <*> (divControlGroup $+ (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (unUACCT _coreUACCT)) `transformEither` toMUACCT))++ <*> (divControlGroup $+ (labelText "/ redirects to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (fromMaybe mempty _coreRootRedirect)) `transformEither` toMaybe))++ <*> (divControlGroup $+ (labelText "Back To Site location" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText _coreBackToSiteRedirect)))++ <*> (divControlGroup $+ (labelText "after login redirect to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (fromMaybe mempty _coreLoginRedirect)) `transformEither` toMaybe))++ <*> bodyPolicyForm+ <*+ (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text])+ where+ bodyPolicyForm =+ let (tmpPath, mDisk, mRam, mHeader) = _coreBodyPolicy in+ (,,,) <$> (divControlGroup $+ (labelText "temporary directory for uploads" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (T.pack tmpPath)) `transformEitherM` toFilePath))+ <*> (divControlGroup $+ (labelText "maximum size for file uploads" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (T.pack $ show $ mDisk)) `transform` (decimalText InvalidDecimal)))+ <*> (divControlGroup $+ (labelText "maximum size for non-file values" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (T.pack $ show $ mRam)) `transform` (decimalText InvalidDecimal)))+ <*> (divControlGroup $+ (labelText "maximum size for overhead of headers in multipart/form-data" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (T.pack $ show $ mHeader)) `transform` (decimalText InvalidDecimal)))+++ -- | read an unsigned number in decimal notation+ decimalText :: (Monad m, Eq i, Num i) =>+ (Text -> error) -- ^ create an error message ('String' is the value that did not parse)+ -> Proof m error Decimal Text i+ decimalText mkError = Proof Decimal (return . toDecimal)+ where+ toDecimal txt =+ case readDec (T.unpack txt) of+ [(d,[])] -> (Right d)+ _ -> (Left $ mkError txt)++ -- | FIXME: should perhaps check that the path exists and is writable?+ toFilePath :: (MonadIO m) => Text -> m (Either ClckFormError FilePath)+ toFilePath t = pure $ Right (T.unpack t)++ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])++ unUACCT (Just (UACCT str)) = pack str+ unUACCT Nothing = mempty++ toMUACCT :: T.Text -> Either ClckFormError (Maybe UACCT)+ toMUACCT str | T.null str = Right $ Nothing+ toMUACCT str = Right $ Just (UACCT $ T.unpack str)++ toMaybe :: Text -> Either ClckFormError (Maybe Text)+ toMaybe txt =+ if T.null txt+ then Right $ Nothing+ else Right $ Just txt++ modifyCoreState sn ua rr bts lr bp =+ c & coreSiteName .~ sn+ & coreUACCT .~ ua+ & coreRootRedirect .~ rr+ & coreBackToSiteRedirect .~ bts+ & coreLoginRedirect .~ lr+ & coreBodyPolicy .~ bp++{-+editUACCTForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT)+editUACCTForm muacct =+ divHorizontal $+ fieldset $ (divControlGroup $- (label "Google Analytics UACCT" `setAttrs` [("class":="control-label")]) ++>+ (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> (divControls (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <*- (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn")])+ (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text]) where divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>]) divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])@@ -43,5 +137,4 @@ toMUACCT :: String -> Either ClckFormError (Maybe UACCT) toMUACCT [] = Right $ Nothing toMUACCT str = Right $ Just (UACCT str)--+-}
Clckwrks/Admin/Route.hs view
@@ -4,6 +4,7 @@ import Clckwrks.Admin.Console (consolePage) import Clckwrks.Admin.EditSettings (editSettings) import Clckwrks.NavBar.EditNavBar (editNavBar, navBarPost)+import Clckwrks.Admin.SystemEmails (systemEmailsPage) -- | routes for 'AdminURL' routeAdmin :: AdminURL -> Clck ClckURL Response@@ -13,3 +14,5 @@ EditSettings -> editSettings (Admin url) EditNavBar -> editNavBar NavBarPost -> navBarPost+ SystemEmails -> systemEmailsPage (Admin url)+
+ Clckwrks/Admin/SystemEmails.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}+module Clckwrks.Admin.SystemEmails where++import Clckwrks+import Clckwrks.Acid (GetUACCT(..), SetUACCT(..))+import Clckwrks.Admin.Template (template)+import Control.Lens ((.~), (&))+import Data.Maybe (maybe, fromMaybe)+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T++-- import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..))+import Happstack.Authenticate.Core (Email(..), SimpleAddress(..))+import HSP.Google.Analytics (UACCT(..))+import HSP.XMLGenerator+import HSP.XML (fromStringLit)+import Language.Haskell.HSX.QQ (hsx)+import Text.Reform+import Text.Reform.Happstack+import Text.Reform.HSP.Text++systemEmailsPage :: ClckURL -> Clck ClckURL Response+systemEmailsPage here =+ do coreState <- query $ GetCoreState+ action <- showURL here+ template "Edit Settings" () $ [hsx|+ <%>+ <% reform (form action) "ss" updateSettings Nothing (editSettingsForm coreState) %>+ </%> |]+ where+ updateSettings :: CoreState -> Clck ClckURL Response+ updateSettings coreState =+ do update (SetCoreState coreState)+ seeOtherURL here+++editSettingsForm :: CoreState -> ClckForm ClckURL CoreState+editSettingsForm c@CoreState{..} =+ divHorizontal $+ fieldset $+ (modifyCoreState <$>+ (divControlGroup $+ (labelText "From: address" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (maybe mempty (_unEmail . _saEmail) _coreFromAddress)) `transformEither` toMaybe))++ <*> (divControlGroup $+ (label ("From: name" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (maybe mempty (fromMaybe mempty . _saName) _coreFromAddress)) `transformEither` toMaybe))++ <*> (divControlGroup $+ (label ("Reply-to: address" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (maybe mempty (_unEmail . _saEmail) _coreReplyToAddress)) `transformEither` toMaybe))++ <*> (divControlGroup $+ (label ("Reply-to: name" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (maybe mempty (fromMaybe mempty . _saName) _coreReplyToAddress)) `transformEither` toMaybe))++ <*> (divControlGroup $+ (labelText "sendmail path" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (maybe mempty T.pack _coreSendmailPath)) `transformEither` toMaybe)))++ <*+ (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text])+ where+ divHorizontal = mapView (\xml -> [[hsx| <div class="form-horizontal"><% xml %></div>|]])+ divControlGroup = mapView (\xml -> [[hsx| <div class="control-group"><% xml %></div>|]])+ divControls = mapView (\xml -> [[hsx| <div class="controls"><% xml %></div>|]])++ toMaybe :: Text -> Either ClckFormError (Maybe Text)+ toMaybe txt =+ if T.null txt+ then Right $ Nothing+ else Right $ Just txt+ modifyCoreState mFromAddress mFromName mReplyToAddress mReplyToName mSendmailPath =+ c & coreFromAddress .~+ case mFromAddress of+ Nothing -> Nothing+ (Just addr) -> Just (SimpleAddress mFromName (Email addr))+ & coreReplyToAddress .~+ case mReplyToAddress of+ Nothing -> Nothing+ (Just addr) -> Just (SimpleAddress mReplyToName (Email addr))+ & coreSendmailPath .~ (T.unpack <$> mSendmailPath)++{-+editUACCTForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT)+editUACCTForm muacct =+ divHorizontal $+ fieldset $+ (divControlGroup $+ (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <*+ (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text])+ where+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])+ unUACCT (Just (UACCT str)) = str+ unUACCT Nothing = ""++ toMUACCT :: String -> Either ClckFormError (Maybe UACCT)+ toMUACCT [] = Right $ Nothing+ toMUACCT str = Right $ Just (UACCT str)+-}
Clckwrks/Admin/Template.hs view
@@ -1,24 +1,91 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, QuasiQuotes #-} module Clckwrks.Admin.Template where -import Clckwrks-import Control.Monad.State (get)-import Data.Maybe (mapMaybe)-import qualified Data.Text as T-import Data.Set (Set)-import qualified Data.Set as Set-+import Control.Applicative ((<$>))+import Control.Monad.Trans (lift)+import Clckwrks.Acid (GetSiteName(..), GetBackToSiteRedirect(..))+import Clckwrks.Monad (ClckT(..), ClckState(adminMenus), plugins, query)+import Clckwrks.URL (ClckURL(JS))+import Clckwrks.JS.URL (JSURL(..))+import {-# SOURCE #-} Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.URL (AuthURL(Auth))+import Clckwrks.ProfileData.API (getUserRoles)+import Clckwrks.ProfileData.Types (Role)+import Control.Monad.State (get)+import Data.Maybe (mapMaybe, fromMaybe)+import Data.Text.Lazy (Text)+import qualified Data.Text as T+import Data.Set (Set)+import qualified Data.Set as Set+import Happstack.Authenticate.Core (AuthenticateURL(Controllers))+import Happstack.Server (Happstack, Response, toResponse)+import HSP.XMLGenerator+import HSP.XML (XML, fromStringLit)+import Language.Haskell.HSX.QQ (hsx)+import Web.Plugins.Core (pluginName, getPluginRouteFn) template :: ( Happstack m , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body ) => String -> headers -> body -> ClckT url m Response-template title headers body =- toResponse <$> (unXMLGenT $+template title headers body = do+ siteName <- (fromMaybe "Your Site") <$> query GetSiteName+ backURL <- query GetBackToSiteRedirect+ p <- plugins <$> get+ ~(Just authShowURL) <- getPluginRouteFn p (pluginName authenticatePlugin)+ ~(Just clckShowURL) <- getPluginRouteFn p "clck"+-- let passwordShowURL u = authShowURL (Auth (AuthenticationMethods $ Just (passwordAuthenticationMethod, toPathSegments u))) []+ toResponse <$> (unXMLGenT $ [hsx| <html> <head>+ <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.3.2/css/bootstrap-combined.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.3.2/js/bootstrap.min.js" ></script>+ <script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular.min.js"></script>+ <script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular-route.min.js"></script>+-- <script src=(passwordShowURL UsernamePasswordCtrl)></script>+ <script src=(clckShowURL (JS ClckwrksApp) [])></script>+ <script src=(authShowURL (Auth Controllers) [])></script>+ <title><% title %></title>+ <% headers %>+ </head>+ <body ng-app="clckwrksApp" ng-controller="AuthenticationCtrl">+ <div class="navbar">+ <div class="navbar-inner">+ <div class="container-fluid">+ <a href=backURL class="brand">Back to <% siteName %></a>+ </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>+ |])++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 $ [hsx|+ <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" />@@ -33,7 +100,7 @@ <div class="navbar"> <div class="navbar-inner"> <div class="container-fluid">- <a href="/" class="brand">Back to Your Site</a>+ <div class="brand"><% siteName %></div> </div> </div> </div>@@ -41,7 +108,7 @@ <div class="container-fluid"> <div class="row-fluid"> <div class="span2">- <% sidebar %>+-- <% sidebar %> </div> <div class="span10"> <% body %>@@ -49,7 +116,7 @@ </div> </div> </body>- </html>)+ </html> |]) sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML@@ -58,11 +125,11 @@ adminMenuXML = do allMenus <- adminMenus <$> get usersMenus <- filterByRole allMenus- <div class="well">+ [hsx| <div class="well"> <ul class="nav nav-list"> <% mapM mkMenu usersMenus %> </ul>- </div>+ </div> |] where -- filterByRole :: [(T.Text, [(Set Role, T.Text, T.Text)])] -> [(T.Text, [(Set Role, T.Text, T.Text)])] filterByRole menus =@@ -75,11 +142,12 @@ itemFilter userRoles (visibleRoles, _, _) = not (Set.null (Set.intersection userRoles visibleRoles)) -- mkMenu :: (Functor m, Monad m) => (T.Text, [(Set Role, T.Text, T.Text)]) -> XMLGenT (ClckT url m) XML- mkMenu (category, links) =+ mkMenu (category, links) = [hsx| <%> <li class="nav-header"><% category %></li> <% mapM mkLink links %>- </%>+ </%> |] mkLink :: (Functor m, Monad m) => (Set Role, T.Text, T.Text) -> XMLGenT (ClckT url m) XML- mkLink (_visible, title, url) =+ mkLink (_visible, title, url) = [hsx| <li><a href=url><% title %></a></li>+ |]
Clckwrks/Admin/URL.hs view
@@ -10,7 +10,8 @@ | EditSettings | EditNavBar | NavBarPost+ | SystemEmails deriving (Eq, Ord, Read, Show, Data, Typeable) $(derivePathInfo ''AdminURL)-$(deriveSafeCopy 2 'base ''AdminURL)+$(deriveSafeCopy 3 'base ''AdminURL)
+ Clckwrks/Authenticate/API.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+module Clckwrks.Authenticate.API+ ( Username(..)+ , getEmail+ , getUser+ , getUsername+ , insecureUpdateUser+ , setCreateUserCallback+ ) where++import Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..))+import Clckwrks.Monad (Clck, ClckPlugins, plugins)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (modifyTVar')+import Control.Monad (join)+import Control.Monad.State (get)+import Control.Monad.Trans (liftIO)+import Data.Acid as Acid (AcidState, query, update)+import Data.Maybe (maybe)+import Data.Monoid (mempty)+import Data.Text (Text)+import Data.UserId (UserId)+import Happstack.Authenticate.Core (AuthenticateConfig(_createUserCallback), GetUserByUserId(..), Email(..), UpdateUser(..), User(..), Username(..))+import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin, modifyPluginState')++getUser :: UserId -> Clck url (Maybe User)+getUser uid =+ do p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid)++-- | Update an existing 'User'. Must already have a valid 'UserId'.+--+-- no security checks are performed to ensure that the caller is+-- authorized to change data for the 'User'.+insecureUpdateUser :: User -> Clck url ()+insecureUpdateUser user =+ do p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ liftIO $ Acid.update (acidStateAuthenticate aps) (UpdateUser user)++getUsername :: UserId -> Clck url (Maybe Username)+getUsername uid =+ do mUser <- getUser uid+ pure $ _username <$> mUser++getEmail :: UserId -> Clck url (Maybe Email)+getEmail uid =+ do mUser <- getUser uid+ pure $ join $ _email <$> mUser++setCreateUserCallback :: ClckPlugins -> Maybe (User -> IO ()) -> IO ()+setCreateUserCallback p mcb =+ do ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ liftIO $ atomically $ modifyTVar' (apsAuthenticateConfigTV aps) $ (\ac -> ac { _createUserCallback = mcb })+ pure ()
+ Clckwrks/Authenticate/Monad.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings, MultiParamTypeClasses #-}+module Clckwrks.Authenticate.Monad where++import Clckwrks.Acid (GetAcidState(..), GetCoreState(..), GetEnableOpenId(..), acidCore, acidProfileData, coreFromAddress, coreReplyToAddress, coreSendmailPath, getAcidState)+import Clckwrks.Monad+import Control.Concurrent.STM.TVar (TVar)+import Control.Monad.State (get)+import Control.Monad.Trans (MonadIO, lift)+import Data.Acid as Acid (AcidState, query)+import Data.Typeable (Typeable)+import Happstack.Authenticate.Core (AuthenticateState, AuthenticateConfig(..), User, getToken, tokenUser, userId, usernamePolicy)+import Happstack.Authenticate.Password.Core (PasswordConfig, PasswordState)+import Web.Plugins.Core (getPluginState)++data AuthenticatePluginState = AuthenticatePluginState+ { acidStateAuthenticate :: AcidState AuthenticateState+ , acidStatePassword :: AcidState PasswordState+ , apsAuthenticateConfigTV :: TVar AuthenticateConfig+ , apsPasswordConfigTV :: TVar PasswordConfig+ }+ deriving Typeable++instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) AuthenticateState where+ getAcidState =+ do p <- plugins <$> get+ ~(Just aps) <- getPluginState p "authenticate"+ pure (acidStateAuthenticate aps)++instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) PasswordState where+ getAcidState =+ do p <- plugins <$> get+ ~(Just aps) <- getPluginState p "authenticate"+ pure (acidStatePassword aps)+
+ Clckwrks/Authenticate/Page/AuthModes.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}+module Clckwrks.Authenticate.Page.AuthModes where++import Clckwrks.Acid (GetEnableOpenId(..), SetEnableOpenId(..))+import Clckwrks.Admin.Template (template)+import Clckwrks.Authenticate.URL (AuthURL(..))+import Clckwrks.Monad+import Clckwrks.URL (ClckURL)+import Control.Lens ((.~), (&))+import Data.Maybe (maybe, fromMaybe)+import Data.Text.Lazy (Text)+import qualified Data.Text as T+import Happstack.Server (Response, ServerPartT, ok, toResponse)+import HSP.XMLGenerator+import HSP.XML (fromStringLit)+import Language.Haskell.HSX.QQ (hsx)+import Text.Reform+import Text.Reform.Happstack+import Text.Reform.HSP.Text+import Web.Routes (showURL)+import Web.Routes.Happstack (seeOtherURL)++authModesPage :: AuthURL -> Clck AuthURL Response+authModesPage here =+ do enableOpenId <- query $ GetEnableOpenId+ action <- showURL here+ template "Authentication Modes" () $+ [hsx|+ <%>+ <% reform (form action) "am" updateAuthModes Nothing (authModesForm enableOpenId) %>+ </%>+ |]+ where+ updateAuthModes :: Bool -> Clck AuthURL Response+ updateAuthModes b =+ do update (SetEnableOpenId b)+ seeOtherURL here++authModesForm :: Bool -> ClckForm AuthURL Bool+authModesForm b =+ divHorizontal $+ fieldset $+ (divControlGroup $+ (labelText "Enable OpenId" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputCheckbox b)))+ <* (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text])++ where+ label' :: Text -> ClckForm AuthURL ()+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])+ divHorizontal = mapView (\xml -> [[hsx|<div class="form-horizontal"><% xml %></div>|]])+ divControlGroup = mapView (\xml -> [[hsx|<div class="control-group"><% xml %></div>|]])+ divControls = mapView (\xml -> [[hsx|<div class="controls"><% xml %></div>|]])+++-- (divControls (inputText (maybe mempty (_unEmail . _saEmail) _coreFromAddress)) `transformEither` toMaybe))
+ Clckwrks/Authenticate/Page/ChangePassword.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}+module Clckwrks.Authenticate.Page.ChangePassword where++import Clckwrks.Admin.Template (template)+import Clckwrks.Monad+import Clckwrks.URL (ClckURL)+import Happstack.Server (Response, ServerPartT, ok, toResponse)+import Language.Haskell.HSX.QQ (hsx)++changePasswordPanel :: ClckT ClckURL (ServerPartT IO) Response+changePasswordPanel =+ do template "Change Password" () $ [hsx|+ <%>+ <h2>Change Password</h2>+ <div ng-controller="UsernamePasswordCtrl">+ <up-change-password />+ </div>+ </%> |]+
+ Clckwrks/Authenticate/Page/Login.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+module Clckwrks.Authenticate.Page.Login where++import Control.Applicative ((<$>))+import Clckwrks.Monad (ClckT, ThemeStyleId(..), plugins, themeTemplate)+import Clckwrks.Authenticate.URL+import Clckwrks.URL (ClckURL)+import Control.Monad.State (get)+import Happstack.Server (Response, ServerPartT)+import HSP+import Language.Haskell.HSX.QQ (hsx)++loginPage :: ClckT ClckURL (ServerPartT IO) Response+loginPage =+ do plugins <- plugins <$> get+ themeTemplate plugins (ThemeStyleId 0) "Login" () [hsx|+ <div ng-controller="UsernamePasswordCtrl">+ <div up-authenticated=False>+ <h2>Login</h2>+ <up-login />++ <h2>Forgotten Password?</h2>+ <p>Forgot your password? Request a reset link via email!</p>+ <up-request-reset-password />+ </div>++ <div up-authenticated=True>+ <h2>Logout</h2>+ <p>You have successfully logged in! Click the link below to logout.</p>+ <up-logout />+ </div>++ <h2>Create A New Account</h2>+ <up-signup-password />+ </div> |]
+ Clckwrks/Authenticate/Page/OpenIdRealm.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}+module Clckwrks.Authenticate.Page.OpenIdRealm where++import Clckwrks.Admin.Template (template)+import Clckwrks.Monad+import Clckwrks.URL (ClckURL)+import Happstack.Server (Response, ServerPartT, ok, toResponse)+import Language.Haskell.HSX.QQ (hsx)++openIdRealmPanel :: ClckT ClckURL (ServerPartT IO) Response+openIdRealmPanel =+ do template "Set OpenId Realm" () $ [hsx|+ <div ng-controller="OpenIdCtrl">+ <openid-realm />+ </div> |]+
+ Clckwrks/Authenticate/Page/ResetPassword.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+module Clckwrks.Authenticate.Page.ResetPassword where++import Control.Applicative ((<$>))+import Clckwrks.Monad (ClckT, ThemeStyleId(..), plugins, themeTemplate)+import Clckwrks.URL (ClckURL(..))+import Clckwrks.Authenticate.URL+import Control.Monad.State (get)+import Happstack.Server (Response, ServerPartT)+import HSP+import Language.Haskell.HSX.QQ (hsx)++resetPasswordPage :: ClckT ClckURL (ServerPartT IO) Response+resetPasswordPage =+ do plugins <- plugins <$> get+ themeTemplate plugins (ThemeStyleId 0) "Reset Password" () [hsx|+ <%>+ <h2>Reset Password</h2>+ <div ng-controller="UsernamePasswordCtrl">+ <up-reset-password />+ </div>+ </%> |]
+ Clckwrks/Authenticate/Page/ViewUsers.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes, OverloadedStrings #-}+module Clckwrks.Authenticate.Page.ViewUsers where++import Clckwrks.Admin.Template (template)+import Clckwrks.Monad+import Clckwrks.URL (ClckURL(..))+import Clckwrks.Authenticate.Monad ()+import Clckwrks.ProfileData.URL(ProfileDataURL(..))+import Data.Maybe (maybe)+import Data.Foldable (toList)+import qualified Data.Text as Text+import Happstack.Server (Response, ServerPartT, ok, toResponse)+import Happstack.Authenticate.Core (Email(..), GetUsers(..), User(..), UserId(..), Username(..))+import Language.Haskell.HSX.QQ (hsx)+import Web.Plugins.Core (Plugin(..), getPluginState)+import Web.Routes (showURL)++viewUsers :: ClckT ClckURL (ServerPartT IO) Response+viewUsers =+ do us <- query GetUsers+ template "View Users" () $ [hsx|+ <div>+ <h2>Users</h2>+ <table class="table">+ <thead>+ <tr><th>UserId</th><th>Username</th><th>Email</th></tr>+ </thead>+ <tbody>+ <% mapM mkRow (toList us) %>+ </tbody>+ </table>+ </div> |]+ where+ mkRow u =+ do epdf <- showURL (Profile (EditProfileDataFor (_userId u)))+ [hsx| <tr><td><a href=(Text.unpack epdf)><% show $ _unUserId $ _userId u %></a></td><td><% _unUsername $ _username u %></td><td><% maybe (Text.empty) _unEmail (_email u) %></td></tr> |]+
+ Clckwrks/Authenticate/Plugin.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings, MultiParamTypeClasses #-}+module Clckwrks.Authenticate.Plugin where++import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (TVar, newTVar)+import Clckwrks.Monad+import Clckwrks.Acid (GetAcidState(..), GetCoreState(..), GetEnableOpenId(..), acidCore, acidProfileData, coreFromAddress, coreLoginRedirect, coreReplyToAddress, coreSendmailPath, getAcidState)+import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..))+import Clckwrks.Authenticate.Route (routeAuth)+import Clckwrks.Authenticate.URL (AuthURL(..))+import Clckwrks.ProfileData.Acid (HasRole(..))+import Clckwrks.ProfileData.Types (Role(..))+import Clckwrks.Types (NamedLink(..))+import Clckwrks.URL+import Control.Applicative ((<$>))+import Control.Lens ((^.))+import Control.Monad.Reader (ask)+import Control.Monad.State (get)+import Control.Monad.Trans (MonadIO, lift)+import Data.Acid as Acid (AcidState, query, openLocalStateFrom)+import Data.Maybe (isJust)+import Data.Monoid ((<>))+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Typeable (Typeable)+import qualified Data.Text as Text+import qualified Data.Set as Set+import qualified Data.Text.Lazy as TL+import Data.UserId (UserId)+import Happstack.Authenticate.Core (AuthenticateState, AuthenticateConfig(..), getToken, tokenUser, userId, usernamePolicy)+import Happstack.Authenticate.Route (initAuthentication)+import Happstack.Authenticate.Password.Core (PasswordConfig(..), initialPasswordState)+import Happstack.Authenticate.Password.Route (initPassword')+import Happstack.Authenticate.OpenId.Route (initOpenId)+import Happstack.Server+import System.FilePath ((</>), combine)+import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin)+import Web.Routes++authenticateHandler+ :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response)+ -> (AuthURL -> [(Text, Maybe Text)] -> Text)+ -> ClckPlugins+ -> [Text]+ -> ClckT ClckURL (ServerPartT IO) Response+authenticateHandler routeAuthenticate showAuthenticateURL _plugins paths =+ case parseSegments fromPathSegments paths of+ (Left e) -> notFound $ toResponse (show e)+ (Right u) -> ClckT $ withRouteT flattenURL $ unClckT $ routeAuth routeAuthenticate u -- ClckT $ withRouteT flattenURL $ unClckT $+ where+ flattenURL :: ((url' -> [(Text, Maybe Text)] -> Text) -> (AuthURL -> [(Text, Maybe Text)] -> Text))+ flattenURL _ u p = showAuthenticateURL u p++authMenuCallback :: (AuthURL -> [(Text, Maybe Text)] -> Text)+ -> ClckT ClckURL IO (String, [NamedLink])+authMenuCallback authShowFn =+ return ("Authenticate", [NamedLink "Login" (authShowFn Login [])])++addAuthAdminMenu :: ClckT url IO ()+addAuthAdminMenu =+ do p <- plugins <$> get+ ~(Just authShowURL) <- getPluginRouteFn p (pluginName authenticatePlugin)+ addAdminMenu ("Authentication", [(Set.fromList [Visitor] , "Change Password" , authShowURL ChangePassword [])])+ addAdminMenu ("Authentication", [(Set.fromList [Administrator], "OpenId Realm" , authShowURL OpenIdRealm [])])+ addAdminMenu ("Authentication", [(Set.fromList [Administrator], "Authentication Modes", authShowURL AuthModes [])])+ addAdminMenu ("Authentication", [(Set.fromList [Administrator], "View Users" , authShowURL ViewUsers [])])++authenticateInit+ :: ClckPlugins+ -> IO (Maybe Text)+authenticateInit plugins =+ do ~(Just authShowFn) <- getPluginRouteFn plugins (pluginName authenticatePlugin)+ addNavBarCallback plugins (authMenuCallback authShowFn)+ -- addHandler plugins (pluginName clckPlugin) (authenticateHandler clckShowFn)+ cc <- getConfig plugins+ acid <- cpsAcid <$> getPluginsSt plugins+ let basePath = maybe "_state" (\top -> top </> "_state") (clckTopDir cc)+ baseUri = case calcTLSBaseURI cc of+ Nothing -> calcBaseURI cc+ (Just b) -> b+ cs <- Acid.query (acidCore acid) GetCoreState+ let authenticateConfig = AuthenticateConfig {+ _isAuthAdmin = \uid -> Acid.query (acidProfileData acid) (HasRole uid (Set.singleton Administrator))+ , _usernameAcceptable = usernamePolicy+ , _requireEmail = True+ , _systemFromAddress = cs ^. coreFromAddress+ , _systemReplyToAddress = cs ^. coreReplyToAddress+ , _systemSendmailPath = cs ^. coreSendmailPath+ , _postLoginRedirect = cs ^. coreLoginRedirect+ , _createUserCallback = Nothing+ }+ passwordConfig = PasswordConfig {+ _resetLink = baseUri <> authShowFn ResetPassword [] <> "/#"+ , _domain = Text.pack $ clckHostname cc+ , _passwordAcceptable = const Nothing+ }++ passwordState <- openLocalStateFrom (combine (combine basePath "authenticate") "password") initialPasswordState+ passwordConfigTV <- atomically $ newTVar passwordConfig+ (authCleanup, routeAuthenticate, authenticateState, authenticateConfigTV) <- initAuthentication (Just basePath) authenticateConfig+ ((initPassword' passwordConfigTV passwordState) : if True then [ initOpenId ] else [])+ addHandler plugins (pluginName authenticatePlugin) (authenticateHandler routeAuthenticate authShowFn)+ addPluginState plugins (pluginName authenticatePlugin) (AuthenticatePluginState authenticateState passwordState authenticateConfigTV passwordConfigTV)+ addCleanup plugins Always authCleanup+ return Nothing+{-+addClckAdminMenu :: ClckT url IO ()+addClckAdminMenu =+ do p <- plugins <$> get+ (Just clckShowURL) <- getPluginRouteFn p (pluginName clckPlugin)+ addAdminMenu ( "Profile"+ , [ (Set.fromList [Administrator, Visitor], "Edit Your Profile" , clckShowURL (Profile EditProfileData) [])+ ]+ )++ addAdminMenu ( "Clckwrks"+ , [ (Set.singleton Administrator, "Console" , clckShowURL (Admin Console) [])+ , (Set.singleton Administrator, "Edit Settings", clckShowURL (Admin EditSettings) [])+ , (Set.singleton Administrator, "Edit Nav Bar" , clckShowURL (Admin EditNavBar) [])+ ]+ )+-}+authenticatePlugin :: Plugin AuthURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+authenticatePlugin = Plugin+ { pluginName = "authenticate"+ , pluginInit = authenticateInit+ , pluginDepends = []+ , pluginToPathSegments = toPathSegments+ , pluginPostHook = addAuthAdminMenu+ }++plugin :: ClckPlugins+ -> Text+ -> IO (Maybe Text)+plugin plugins baseURI =+ initPlugin plugins baseURI authenticatePlugin++getUserId :: (Happstack m) => ClckT url m (Maybe UserId)+getUserId =+ do p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ mToken <- getToken (acidStateAuthenticate aps)+ case mToken of+ Nothing -> return Nothing+ (Just (token, _)) -> return $ Just (token ^. tokenUser ^. userId)+
+ Clckwrks/Authenticate/Plugin.hs-boot view
@@ -0,0 +1,13 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings #-}+module Clckwrks.Authenticate.Plugin where++import Clckwrks.Authenticate.URL (AuthURL)+import Clckwrks.Monad+import Clckwrks.URL+import Data.UserId (UserId)+import Happstack.Server+import Web.Plugins.Core (Plugin(..), addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, initPlugin)++authenticatePlugin :: Plugin AuthURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt++getUserId :: (Happstack m) => ClckT url m (Maybe UserId)
+ Clckwrks/Authenticate/Route.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+module Clckwrks.Authenticate.Route where++import Control.Applicative ((<$>))+import Clckwrks.Monad (ClckT(..), plugins)+import Clckwrks.Authenticate.URL (AuthURL(..))+import Clckwrks.Authenticate.Page.AuthModes (authModesPage)+import Clckwrks.Authenticate.Page.Login (loginPage)+import Clckwrks.Authenticate.Page.ChangePassword (changePasswordPanel)+import Clckwrks.Authenticate.Page.ResetPassword (resetPasswordPage)+import Clckwrks.Authenticate.Page.OpenIdRealm (openIdRealmPanel)+import Clckwrks.Authenticate.Page.ViewUsers (viewUsers)+import Clckwrks.ProfileData.API (Role(..), requiresRole_)+import Clckwrks.URL (ClckURL)+-- import Clckwrks.Plugin (clckPlugin)+import Control.Monad.State (get)+import Control.Monad.Trans (lift)+import qualified Data.Set as Set+import Happstack.Authenticate.Core (AuthenticateURL)+import Happstack.Server (Happstack, Response, ServerPartT)+import Web.Routes (RouteT(..), askRouteFn, runRouteT)+import Web.Plugins.Core (getPluginRouteFn, pluginName)++-- | routeAuth+-- there is much craziness here. This should be more like clckwrks-plugin-page or something+routeAuth :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response)+ -> AuthURL+ -> ClckT AuthURL (ServerPartT IO) Response+routeAuth routeAuthenticate u' =+ do u <- checkAuth u'+ p <- plugins <$> get+ ~(Just clckShowFn) <- getPluginRouteFn p "clck" -- (pluginName clckPlugin) -- a mildly dangerous hack to avoid circular depends+ let withClckURL m = ClckT $ RouteT $ \_ -> unRouteT (unClckT m) clckShowFn+ case u of+ (Auth authenticateURL) ->+ do p <- plugins <$> get+ ~(Just authShowFn) <- getPluginRouteFn p "authenticate"+ lift $ runRouteT routeAuthenticate (authShowFn . Auth) authenticateURL+ Login -> withClckURL loginPage+ ResetPassword -> withClckURL resetPasswordPage+ ChangePassword -> withClckURL changePasswordPanel+ OpenIdRealm -> withClckURL openIdRealmPanel+ AuthModes -> authModesPage u+ ViewUsers -> withClckURL viewUsers++checkAuth :: (Happstack m, Monad m) =>+ AuthURL+ -> ClckT AuthURL m AuthURL+checkAuth url =+ do p <- plugins <$> get+ ~(Just clckShowFn) <- getPluginRouteFn p "clck" -- (pluginName clckPlugin) -- a mildly dangerous hack to avoid circular depends+ let requiresRole = requiresRole_ clckShowFn+ case url of+ (Auth {}) -> pure url+ Login -> pure url+ ResetPassword -> pure url+ AuthModes -> requiresRole (Set.fromList [Administrator]) url+ ChangePassword -> requiresRole (Set.fromList [Visitor]) url+ OpenIdRealm -> requiresRole (Set.fromList [Administrator]) url+ ViewUsers -> requiresRole (Set.fromList [Administrator]) url
+ Clckwrks/Authenticate/URL.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, TemplateHaskell, TypeFamilies #-}+module Clckwrks.Authenticate.URL+ ( AuthURL(..)+ )+ where++import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Happstack.Authenticate.Core (AuthenticateURL(..))+import Web.Routes.TH (derivePathInfo)++data AuthURL+ = Auth AuthenticateURL+ | Login+ | ResetPassword+ | ChangePassword+ | OpenIdRealm+ | AuthModes+ | ViewUsers+ deriving (Eq, Ord, Data, Typeable, Generic, Read, Show)++derivePathInfo ''AuthURL
Clckwrks/BasicTemplate.hs view
@@ -1,19 +1,20 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.BasicTemplate (basicTemplate) where import Control.Applicative ((<$>)) import Clckwrks.Monad+import Data.Text.Lazy (Text) import Happstack.Server (Response, toResponse)-import Happstack.Server.HSP.HTML ()-import HSP+import HSP.XMLGenerator+import HSP.XML -basicTemplate :: +basicTemplate :: ( Functor m , Monad m , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body- ) => String -> headers -> body -> ClckT url m Response+ ) => Text -> headers -> body -> ClckT url m Response basicTemplate title headers body = toResponse <$> (unXMLGenT $ <html>
Clckwrks/GetOpts.hs view
@@ -30,9 +30,11 @@ , Option [] ["http-port"] (ReqArg setPort "port") ("Port to bind http server, default: " ++ show (clckPort def)) , Option [] ["https-port"] (ReqArg setTLSPort "port") ("Port to bind https server, default:" ++ maybe "disabled." show (clckTLSPort <$> (clckTLS def))) , Option [] ["tls-cert"] (ReqArg setTLSCert "path") ("Path to tls .cert file. (required for https).")- , Option [] ["tls-key"] (ReqArg setTLSKey "path") ("Path to tls .key file. (required for https).")+ , Option [] ["tls-key"] (ReqArg setTLSKey "path") ("Path to tls .key file. (required for https).")+ , Option [] ["tls-ca"] (ReqArg setTLSCA "path") ("Path to tls .pem file. (required for some certs).")+ , Option [] ["tls-rev-proxy"] (NoArg setTLSRevProxy) ("Act as a reverse proxy and trust X-Forwarded-Proto for TLS.") , Option [] ["hide-port"] (NoArg setHidePort) "Do not show the port number in the URL"- , Option [] ["hostname"] (ReqArg setHostname "hostname") ("Server hostename, default: " ++ show (clckHostname def))+ , Option [] ["hostname"] (ReqArg setHostname "hostname") ("Server hostname, default: " ++ show (clckHostname def)) , Option [] ["jquery-path"] (ReqArg setJQueryPath "path") ("path to jquery directory, default: " ++ show (clckJQueryPath def)) , Option [] ["jqueryui-path"] (ReqArg setJQueryUIPath "path") ("path to jqueryui directory, default: " ++ show (clckJQueryUIPath def)) , Option [] ["jstree-path"] (ReqArg setJSTreePath "path") ("path to jstree directory, default: " ++ show (clckJSTreePath def))@@ -42,8 +44,10 @@ ] where nullTLSSettings = TLSSettings { clckTLSPort = 443- , clckTLSCert = ""- , clckTLSKey = ""+ , clckTLSCert = Nothing+ , clckTLSKey = Nothing+ , clckTLSCA = Nothing+ , clckTLSRev = False } modifyTLS f cc = Just $ case clckTLS cc of@@ -52,8 +56,10 @@ noop _ = ModifyConfig $ id setPort str = ModifyConfig $ \c -> c { clckPort = read str } setTLSPort str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSPort = read str }) c }- setTLSCert str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCert = str }) c }- setTLSKey str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSKey = str }) c }+ setTLSCert str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCert = Just str }) c }+ setTLSKey str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSKey = Just str }) c }+ setTLSCA str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCA = Just str }) c }+ setTLSRevProxy = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSRev = True}) c } setHostname str = ModifyConfig $ \c -> c { clckHostname = str } setHidePort = ModifyConfig $ \c -> c { clckHidePort = True } setJQueryPath str = ModifyConfig $ \c -> c { clckJQueryPath = str }@@ -84,19 +90,27 @@ Nothing -> return cc (Just TLSSettings{..}) -> do mCertError <-- if null clckTLSCert- then return (Just "--tls-cert not set.")- else do b <- doesFileExist clckTLSCert- if b- then return Nothing- else return (Just $ "Can not find the file " ++ clckTLSCert)+ case clckTLSCert of+ Nothing ->+ if clckTLSRev+ then return Nothing+ else return (Just "--tls-cert not set.")+ (Just certPath) -> do+ b <- doesFileExist certPath+ if b+ then return Nothing+ else return (Just $ "Can not find the file " ++ certPath) mKeyError <-- if null clckTLSKey- then return (Just "--tls-key not set.")- else do b <- doesFileExist clckTLSKey- if b- then return Nothing- else return (Just $ "Can not find the file " ++ clckTLSKey)+ case clckTLSKey of+ Nothing ->+ if clckTLSRev+ then return Nothing+ else return (Just "--tls-key not set.")+ (Just keyPath) -> do+ b <- doesFileExist keyPath+ if b+ then return Nothing+ else return (Just $ "Can not find the file " ++ keyPath) case (mCertError, mKeyError) of (Nothing, Nothing) -> return cc _ -> do putStrLn "It seems you are trying to enable https support. To do that you need to use both the --tls-cert and --tls-key flags."
+ Clckwrks/JS/ClckwrksApp.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}+module Clckwrks.JS.ClckwrksApp where++import Language.Javascript.JMacro++clckwrksAppJS :: Bool -> JStat+clckwrksAppJS True = [jmacro|+ {+ var clckwrksApp = angular.module('clckwrksApp', [+ 'happstackAuthentication',+ 'usernamePassword',+ 'openId',+ 'ngRoute'+ ]);++ clckwrksApp.config(['$routeProvider',+ function($routeProvider) {+ $routeProvider.when('/resetPassword',+ { templateUrl: '/authenticate/authentication-methods/password/partial/reset-password-form',+ controller: 'UsernamePasswordCtrl'+ });+ }]);++ clckwrksApp.controller('ClckwrksCtrl', ['$scope', '$http',function($scope, $http) {+ return;+ }]);+ }+ |]+clckwrksAppJS False = [jmacro|+ {+ var clckwrksApp = angular.module('clckwrksApp', [+ 'happstackAuthentication',+ 'usernamePassword',+ 'ngRoute'+ ]);++ clckwrksApp.config(['$routeProvider',+ function($routeProvider) {+ $routeProvider.when('/resetPassword',+ { templateUrl: '/authenticate/authentication-methods/password/partial/reset-password-form',+ controller: 'UsernamePasswordCtrl'+ });+ }]);++ clckwrksApp.controller('ClckwrksCtrl', ['$scope', '$http',function($scope, $http) {+ return;+ }]);+ }+ |]
+ Clckwrks/JS/Route.hs view
@@ -0,0 +1,13 @@+module Clckwrks.JS.Route where++import Control.Applicative ((<$>))+import Clckwrks.Monad (ClckT)+import Clckwrks.JS.ClckwrksApp (clckwrksAppJS)+import Clckwrks.JS.URL+import Happstack.Server (Happstack, Response, ok, toResponse)+import Happstack.Server.JMacro ()++routeJS :: (Happstack m) => Bool -> JSURL -> ClckT u m Response+routeJS enableOpenId url =+ case url of+ ClckwrksApp -> ok $ toResponse $ clckwrksAppJS enableOpenId
+ Clckwrks/JS/URL.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell #-}+{- |URLs for JavaScript fragments+-}+module Clckwrks.JS.URL where++import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Web.Routes.TH (derivePathInfo)++data JSURL+ = ClckwrksApp -- AngularJS App controller+ deriving (Eq, Ord, Data, Typeable, Generic, Read, Show)++derivePathInfo ''JSURL
Clckwrks/Markup/Markdown.hs view
@@ -40,4 +40,5 @@ return (Left e) ExitSuccess -> do m <- readMVar mvOut+ e <- readMVar mvErr return (Right ((if (trust == Untrusted) then sanitizeBalance else id) m))
+ Clckwrks/Markup/Pandoc.hs view
@@ -0,0 +1,43 @@+module Clckwrks.Markup.Pandoc where++import Clckwrks.Types (Trust(..))+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Text.HTML.SanitizeXSS (sanitizeBalance)+import System.Exit (ExitCode(ExitFailure, ExitSuccess))+import System.IO (hClose)+import System.Process (waitForProcess, runInteractiveProcess)++-- | run the text through the 'markdown' executable. If successful,+-- and the input is marked 'Untrusted', run the output through+-- xss-sanitize / sanitizeBalance to prevent injection attacks.+pandoc :: (MonadIO m) =>+ Maybe [String] -- ^ override command-line flags+ -> Trust -- ^ do we trust the author+ -> Text -- ^ markdown text+ -> m (Either Text Text) -- ^ Left error, Right html+pandoc mArgs trust txt = liftIO $+ do let args = case mArgs of+ Nothing -> []+ (Just a) -> a+ (inh, outh, errh, ph) <- runInteractiveProcess "pandoc" args Nothing Nothing+ _ <- forkIO $ do T.hPutStr inh txt+ hClose inh+ mvOut <- newEmptyMVar+ _ <- forkIO $ do c <- T.hGetContents outh+ putMVar mvOut c+ mvErr <- newEmptyMVar+ _ <- forkIO $ do c <- T.hGetContents errh+ putMVar mvErr c+ ec <- waitForProcess ph+ case ec of+ (ExitFailure _) ->+ do e <- readMVar mvErr+ return (Left e)+ ExitSuccess ->+ do m <- readMVar mvOut+ return (Right ((if (trust == Untrusted) then sanitizeBalance else id) m))
Clckwrks/Monad.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings #-}+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings, TemplateHaskell #-} module Clckwrks.Monad ( Clck , ClckPlugins- , ClckPluginsSt+ , ClckPluginsSt(cpsAcid) , initialClckPluginsSt , ClckT(..) , ClckForm@@ -13,7 +13,10 @@ , TLSSettings(..) , AttributeType(..) , Theme(..)+ , ThemeStyle(..)+ , ThemeStyleId(..) , ThemeName+ , getThemeStyles , themeTemplate , calcBaseURI , calcTLSBaseURI@@ -23,11 +26,11 @@ , mapClckT , withRouteClckT , ClckState(..)- , getUserId , Content(..) -- , markupToContent -- , addPreProcessor , addAdminMenu+ , appendRequestInit , getNavBarLinks , addPreProc , addNavBarCallback@@ -37,42 +40,48 @@ , googleAnalytics , getUnique , setUnique- , requiresRole- , requiresRole_- , getUserRoles+ , setRedirectCookie+ , getRedirectCookie , query , update , nestURL+ , isSecure , withAbs , withAbs' , segments , transform+ , module HSP.XML+ , module HSP.XMLGenerator ) where import Clckwrks.Admin.URL (AdminURL(..)) import Clckwrks.Acid (Acid(..), CoreState, GetAcidState(..), GetUACCT(..))-import Clckwrks.ProfileData.Acid (ProfileDataState, ProfileDataError(..), GetRoles(..), HasRole(..))+import Clckwrks.ProfileData.Acid (ProfileDataState, GetRoles(..), HasRole(..)) import Clckwrks.ProfileData.Types (Role(..)) import Clckwrks.NavBar.Acid (NavBarState) import Clckwrks.NavBar.Types (NavBarLinks(..)) 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)+#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0)+import Control.Monad.Fail (MonadFail)+#endif 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)-import Control.Monad.Trans (MonadIO(liftIO), lift)+import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(lift)) import Control.Concurrent.STM (TVar, readTVar, writeTVar, atomically) import Data.Acid (AcidState, EventState, EventResult, QueryEvent, UpdateEvent) import Data.Acid.Advanced (query', update') import Data.Attoparsec.Text.Lazy (Parser, parseOnly, char, asciiCI, try, takeWhile, takeWhile1) import qualified Data.HashMap.Lazy as HashMap+ import qualified Data.List as List import qualified Data.Map as Map import Data.Monoid ((<>), mappend, mconcat)-import qualified Data.Text as Text+import qualified Data.Serialize as S import Data.Traversable (sequenceA) import qualified Data.Vector as Vector import Data.ByteString.Lazy as LB (ByteString)@@ -80,31 +89,38 @@ import Data.Data (Data, Typeable) import Data.Map (Map) import Data.Maybe (fromJust)-import Data.SafeCopy (SafeCopy(..))+import Data.SafeCopy (SafeCopy(..), Contained, deriveSafeCopy, base, contain) import Data.Set (Set) import qualified Data.Set as Set+import Data.Sequence (Seq) import qualified Data.Text as T+import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (Builder, fromText) import qualified Data.Text.Lazy.Builder as B import Data.Time.Clock (UTCTime) import Data.Time.Format (formatTime)-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(..), ServerPartT, UnWebT, internalServerError, mapServerPartT, escape, toResponse)+import Data.UserId (UserId(..))+import Happstack.Server ( CookieLife(Session), Happstack, ServerMonad(..), FilterMonad(..)+ , WebMonad(..), Input, Request(..), Response, HasRqData(..)+ , ServerPart, ServerPartT, UnWebT, addCookie, expireCookie, escape+ , internalServerError, lookCookieValue, mapServerPartT, mkCookie+ , toResponse, getHeaderUnsafe+ ) 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.ServerPartT ()-import HSX.XMLGenerator (XMLGen(..))-import HSX.JMacro (IntegerSupply(..))+-- import HSP hiding (Request, escape)+import HSP.Google.Analytics (UACCT, universalAnalytics)+-- import HSP.ServerPartT ()+import HSP.XML+import HSP.XMLGenerator+import HSP.JMacro (IntegerSupply(..)) import Language.Javascript.JMacro import Prelude hiding (takeWhile)-import System.Locale (defaultTimeLocale)+import Data.Time.Locale.Compat (defaultTimeLocale) -- can import from time directly when time-1.4/ghc 7.8 is not important anymore import Text.Blaze.Html (Html)-import Text.Blaze.Html.Renderer.String (renderHtml)+import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Reform (CommonFormError, Form, FormError(..)) import Web.Routes (URL, MonadRoute(askRouteFn), RouteT(RouteT, unRouteT), mapRouteT, showURL, withRouteT) import Web.Plugins.Core (Plugins, getConfig, getPluginsSt, modifyPluginsSt, getTheme)@@ -112,57 +128,85 @@ import Web.Routes.Happstack (seeOtherURL) -- imported so that instances are scope even though we do not use them here import Web.Routes.XMLGenT () -- imported so that instances are scope even though we do not use them here -data ClckPluginsSt = ClckPluginsSt- { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO TL.Text]- , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]- }+------------------------------------------------------------------------------+-- Theme+------------------------------------------------------------------------------ -initialClckPluginsSt :: ClckPluginsSt-initialClckPluginsSt = ClckPluginsSt- { cpsPreProcessors = []- , cpsNavBarLinks = []- }+type ThemeName = T.Text --- | ClckPlugins------ newtype Plugins theme m hook config st-type ClckPlugins = Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+newtype ThemeStyleId = ThemeStyleId { unThemeStyleId :: Int }+ deriving (Eq, Ord, Read, Show, Data, Typeable) -type ThemeName = T.Text+instance SafeCopy ThemeStyleId where+ getCopy = contain $ ThemeStyleId <$> S.get+ putCopy (ThemeStyleId i) = contain $ S.put i+ errorTypeName _ = "ThemeStyleId" +data ThemeStyle = ThemeStyle+ { themeStyleName :: T.Text+ , themeStyleDescription :: T.Text+ , themeStylePreview :: Maybe FilePath+ , themeStyleTemplate :: forall headers body.+ ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers+ , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>+ T.Text+ -> headers+ -> body+ -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML+ }+ data Theme = Theme { themeName :: ThemeName- , _themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers- , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>- T.Text- -> headers- -> body- -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML--- , themeBlog :: XMLGenT (ClckT ClckURL (ServerPartT IO)) XML+ , themeStyles :: [ThemeStyle] , themeDataDir :: IO FilePath } - themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body ) => ClckPlugins+ -> ThemeStyleId -> T.Text -> headers -> body -> ClckT ClckURL (ServerPartT IO) Response-themeTemplate plugins ttl hdrs bdy =+themeTemplate plugins tsid ttl hdrs bdy = do mTheme <- getTheme plugins case mTheme of Nothing -> escape $ internalServerError $ toResponse $ ("No theme package is loaded." :: T.Text)- (Just theme) -> fmap toResponse $ unXMLGenT $ (_themeTemplate theme ttl hdrs bdy)+ (Just theme) ->+ case lookupThemeStyle tsid (themeStyles theme) of+ Nothing -> escape $ internalServerError $ toResponse $ ("The current theme does not seem to contain any theme styles." :: T.Text)+ (Just themeStyle) ->+ fmap toResponse $ unXMLGenT $ ((themeStyleTemplate themeStyle) ttl hdrs bdy) +lookupThemeStyle :: ThemeStyleId -> [a] -> Maybe a+lookupThemeStyle _ [] = Nothing+lookupThemeStyle (ThemeStyleId 0) (t:_) = Just t+lookupThemeStyle (ThemeStyleId n) (t':ts) = lookupThemeStyle' (n - 1) ts+ where+ lookupThemeStyle' _ [] = Just t'+ lookupThemeStyle' 0 (t:ts) = Just t+ lookupThemeStyle' n (_:ts) = lookupThemeStyle' (n - 1) ts +getThemeStyles :: (MonadIO m) => ClckPlugins -> m [(ThemeStyleId, ThemeStyle)]+getThemeStyles plugins =+ do mTheme <- getTheme plugins+ case mTheme of+ Nothing -> return []+ (Just theme) -> return $ zip (map ThemeStyleId [0..]) (themeStyles theme) +------------------------------------------------------------------------------+-- ClckwrksConfig+------------------------------------------------------------------------------++ data TLSSettings = TLSSettings { clckTLSPort :: Int- , clckTLSCert :: FilePath- , clckTLSKey :: FilePath+ , clckTLSCert :: Maybe FilePath+ , clckTLSKey :: Maybe FilePath+ , clckTLSCA :: Maybe FilePath+ , clckTLSRev :: Bool } data ClckwrksConfig = ClckwrksConfig@@ -191,19 +235,36 @@ (Just tlsSettings) -> Just $ Text.pack $ "https://" ++ (clckHostname c) ++ if ((clckPort c /= 443) && (clckHidePort c == False)) then (':' : show (clckTLSPort tlsSettings)) else "" -data ClckState- = ClckState { acidState :: Acid- , uniqueId :: TVar Integer -- only unique for this request- , adminMenus :: [(T.Text, [(Set Role, T.Text, T.Text)])]- , enableAnalytics :: Bool -- ^ enable Google Analytics- , plugins :: ClckPlugins- }+------------------------------------------------------------------------------+-- ClckState+------------------------------------------------------------------------------ ++data ClckState = ClckState+ { acidState :: Acid+ , uniqueId :: TVar Integer -- only unique for this request+ , adminMenus :: [(T.Text, [(Set Role, T.Text, T.Text)])]+ , enableAnalytics :: Bool -- ^ enable Google Analytics+ , plugins :: ClckPlugins+ , requestInit :: ServerPart () -- ^ an action which gets called at the beginning of each request+ }++------------------------------------------------------------------------------+-- ClckT+------------------------------------------------------------------------------+ newtype ClckT url m a = ClckT { unClckT :: RouteT url (StateT ClckState m) a }+#if MIN_VERSION_base(4,9,0)+ deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadFail, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState)+#else deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState)+#endif instance (Happstack m) => Happstack (ClckT url m) +instance MonadTrans (ClckT url) where+ lift = ClckT . lift . lift+ -- | evaluate a 'ClckT' returning the inner monad -- -- similar to 'evalStateT'.@@ -247,8 +308,8 @@ -- | error returned when a reform 'Form' fails to validate data ClckFormError = ClckCFE (CommonFormError [Input])- | PDE ProfileDataError | EmptyUsername+ | InvalidDecimal T.Text deriving (Show) instance FormError ClckFormError where@@ -259,6 +320,31 @@ type ClckFormT error m = Form m [Input] error [XMLGenT m XML] () type ClckForm url = Form (ClckT url (ServerPartT IO)) [Input] ClckFormError [XMLGenT (ClckT url (ServerPartT IO)) XML] () +++------------------------------------------------------------------------------+-- ClckPlugins / ClckPluginsSt+------------------------------------------------------------------------------++data ClckPluginsSt = ClckPluginsSt+ { cpsPreProcessors :: forall m. (Functor m, MonadIO m, Happstack m) => [TL.Text -> ClckT ClckURL m TL.Text]+ , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]+ , cpsAcid :: Acid -- ^ this value is also in ClckState, but it is sometimes needed by plugins during initPlugin+ }++initialClckPluginsSt :: Acid -> ClckPluginsSt+initialClckPluginsSt acid = ClckPluginsSt+ { cpsPreProcessors = []+ , cpsNavBarLinks = []+ , cpsAcid = acid+ }++-- | ClckPlugins+--+-- newtype Plugins theme m hook config st+type ClckPlugins = Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt++ setUnique :: (Functor m, MonadIO m) => Integer -> ClckT url m () setUnique i = do u <- uniqueId <$> get@@ -278,6 +364,7 @@ getEnableAnalytics :: (Functor m, MonadState ClckState m) => m Bool getEnableAnalytics = enableAnalytics <$> get +-- | add an Admin menu addAdminMenu :: (Monad m) => (T.Text, [(Set Role, T.Text, T.Text)]) -> ClckT url m () addAdminMenu (category, entries) = modify $ \cs ->@@ -285,6 +372,11 @@ newMenus = Map.toAscList $ Map.insertWith List.union category entries $ Map.fromList oldMenus in cs { adminMenus = newMenus } +-- | append an action to the request init+appendRequestInit :: (Monad m) => ServerPart () -> ClckT url m ()+appendRequestInit action =+ modify $ \cs -> cs { requestInit = (requestInit cs) >> action }+ -- | change the route url withRouteClckT :: ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> url -> [(T.Text, Maybe T.Text)] -> T.Text) -> ClckT url m a@@ -296,17 +388,27 @@ instance (Functor m, MonadIO m) => IntegerSupply (ClckT url m) where nextInteger = getUnique -instance ToJExpr Text.Text where- toJExpr t = ValExpr $ JStr $ T.unpack t- nestURL :: (url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a nestURL f (ClckT r) = ClckT $ R.nestURL f r +isSecure :: ClckwrksConfig -> Request -> Bool+isSecure cc req =+ case rqSecure req of+ True -> True+ False -> case clckTLS cc of+ Nothing -> False+ Just tlsSettings ->+ case clckTLSRev tlsSettings of+ False -> False+ True -> case getHeaderUnsafe "x-forwarded-proto" req of+ Nothing -> False+ Just proto -> proto == "https"+ withAbs :: (Happstack m) => ClckT url m a -> ClckT url m a withAbs m =- do secure <- rqSecure <$> askRq- clckState <- get+ do clckState <- get cc <- getConfig (plugins clckState)+ secure <- isSecure cc <$> askRq let base = if secure then (fromJust $ calcTLSBaseURI cc) else calcBaseURI cc withAbs' base m @@ -336,12 +438,6 @@ instance (GetAcidState m st) => GetAcidState (XMLGenT m) st where getAcidState = XMLGenT getAcidState -instance (Functor m, Monad m) => GetAcidState (ClckT url m) AuthState where- getAcidState = (acidAuth . acidState) <$> get--instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileState where- getAcidState = (acidProfile . acidState) <$> get- instance (Functor m, Monad m) => GetAcidState (ClckT url m) CoreState where getAcidState = (acidCore . acidState) <$> get @@ -351,17 +447,11 @@ instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileDataState where getAcidState = (acidProfileData . acidState) <$> get --- | The the 'UserId' of the current user. While return 'Nothing' if they are not logged in.-getUserId :: (Happstack m, GetAcidState m AuthState, GetAcidState m ProfileState) => m (Maybe UserId)-getUserId =- do authState <- getAcidState- profileState <- getAcidState- Auth.getUserId authState profileState- -- * XMLGen / XMLGenerator instances for Clck instance (Functor m, Monad m) => XMLGen (ClckT url m) where type XMLType (ClckT url m) = XML+ type StringType (ClckT url m) = TL.Text newtype ChildType (ClckT url m) = ClckChild { unClckChild :: XML } newtype AttributeType (ClckT url m) = ClckAttr { unClckAttr :: Attribute } genElement n attrs children =@@ -386,67 +476,67 @@ flP [] bs = reverse bs flP [x] bs = reverse (x:bs) flP (x:y:xs) bs = case (x,y) of- (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs+ (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1<>s2) : xs) bs _ -> flP (y:xs) (x:bs)-+{- instance (Functor m, Monad m) => IsAttrValue (ClckT url m) T.Text where toAttrValue = toAttrValue . T.unpack instance (Functor m, Monad m) => IsAttrValue (ClckT url m) TL.Text where toAttrValue = toAttrValue . TL.unpack-+-} instance (Functor m, Monad m) => EmbedAsAttr (ClckT url m) Attribute where asAttr = return . (:[]) . ClckAttr -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n String) where- asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n String) where+ asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal $ TL.pack str) -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Char) where- asAttr (n := c) = asAttr (n := [c])+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Char) where+ asAttr (n := c) = asAttr (n := TL.singleton c) -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Bool) where+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Bool) where asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true") asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false") -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Int) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Int) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal $ TL.pack (show i)) -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Integer) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Integer) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal $ TL.pack (show i)) -instance (IsName n) => EmbedAsAttr (Clck ClckURL) (Attr n ClckURL) where+instance (IsName n TL.Text) => EmbedAsAttr (Clck ClckURL) (Attr n ClckURL) where asAttr (n := u) = do url <- showURL u- asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))+ asAttr $ MkAttr (toName n, pAttrVal $ TL.fromStrict url) -instance (IsName n) => EmbedAsAttr (Clck AdminURL) (Attr n AdminURL) where+instance (IsName n TL.Text) => EmbedAsAttr (Clck AdminURL) (Attr n AdminURL) where asAttr (n := u) = do url <- showURL u- asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict url)) -instance (Functor m, Monad m, IsName n) => (EmbedAsAttr (ClckT url m) (Attr n TL.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)+instance (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ClckT url m) (Attr n TL.Text)) where+ asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ a) -instance (Functor m, Monad m, IsName n) => (EmbedAsAttr (ClckT url m) (Attr n T.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)+instance (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ClckT url m) (Attr n T.Text)) where+ asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.fromStrict a) instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Char where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . (:[])+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.singleton instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) String where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Int where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Integer where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Double where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Float where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) TL.Text where asChild = asChild . TL.unpack@@ -511,12 +601,12 @@ deriving (Eq, Ord, Read, Show, Data, Typeable) instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Content where- asChild (TrustedHtml html) = asChild $ cdata (T.unpack html)- asChild (PlainText txt) = asChild $ pcdata (T.unpack txt)+ asChild (TrustedHtml html) = asChild $ cdata (TL.fromStrict html)+ asChild (PlainText txt) = asChild $ pcdata (TL.fromStrict txt) addPreProc :: (MonadIO m) => Plugins theme n hook config ClckPluginsSt- -> (TL.Text -> ClckT ClckURL IO TL.Text)+ -> (forall mm. (Functor mm, MonadIO mm, Happstack mm) => TL.Text -> ClckT ClckURL mm TL.Text) -> m () addPreProc plugins p = modifyPluginsSt plugins $ \cps -> cps { cpsPreProcessors = p : (cpsPreProcessors cps) }@@ -572,31 +662,16 @@ -- * Require Role -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--requiresRole :: (Happstack m) => Set Role -> url -> ClckT ClckURL m url-requiresRole role url =- do mu <- getUserId- case mu of- Nothing -> escape $ seeOtherURL (Auth $ AuthURL A_Login)- (Just uid) ->- do r <- query (HasRole uid role)- if r- then return url- else escape $ unauthorizedPage ("You do not have permission to view this page." :: T.Text)+setRedirectCookie :: (Happstack m) =>+ String -> m ()+setRedirectCookie url =+ addCookie Session (mkCookie "clckwrks-authenticate-redirect" url) -getUserRoles :: (Happstack m, MonadIO m) => ClckT u m (Set Role)-getUserRoles =- do mu <- getUserId- case mu of- Nothing -> return (Set.singleton Visitor)- (Just u) ->- do mr <- query (GetRoles u)- case mr of- Nothing -> return Set.empty- (Just r) -> return r+getRedirectCookie :: (Happstack m) =>+ m (Maybe String)+getRedirectCookie =+ do expireCookie "clckwrks-authenticate-redirect"+ optional $ lookCookieValue "clckwrks-authenticate-redirect" ------------------------------------------------------------------------------ -- NavBar callback@@ -619,11 +694,10 @@ getPreProcessors :: (MonadIO m) => Plugins theme n hook config ClckPluginsSt- -> ClckT url m [TL.Text -> ClckT ClckURL IO TL.Text]+ -> (forall mm. (Functor mm, MonadIO mm, Happstack mm) => ClckT url m [TL.Text -> ClckT ClckURL mm TL.Text]) getPreProcessors plugins =- mapClckT liftIO $- (cpsPreProcessors <$> getPluginsSt plugins)-+ do st <- liftIO $ getPluginsSt plugins+ pure (cpsPreProcessors st) -- | create a google analytics tracking code block --@@ -642,4 +716,4 @@ case muacct of Nothing -> return $ cdata "" (Just uacct) ->- analyticsAsync uacct+ universalAnalytics uacct
@@ -1,9 +1,13 @@-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.NavBar.API where import Clckwrks import Clckwrks.NavBar.Acid import Clckwrks.NavBar.Types+import Data.Text.Lazy (Text)+import HSP.XMLGenerator+import HSP.XML getNavBarData :: (Functor m, MonadIO m) => ClckT url m NavBar getNavBarData = query GetNavBar
@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings, QuasiQuotes, RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.NavBar.EditNavBar where import Clckwrks.Admin.Template (template)@@ -13,11 +13,14 @@ import Control.Monad.State (get) import Control.Monad.Trans (lift, liftIO) import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=), decode, object)-import Data.Text (Text)+import Data.Aeson.QQ (aesonQQ)+import qualified Data.Text as T+import Data.Text.Lazy (Text) import Data.Tree (Tree(..)) import qualified Data.Vector as Vector import Happstack.Server (Response, internalServerError, lookBS, ok, toResponse)-import HSP+import HSP.XML (XML, fromStringLit)+import HSP.XMLGenerator import Language.Javascript.JMacro import Web.Routes (showURL) @@ -50,17 +53,7 @@ </div> </div> </div>- </fieldset>- -- <button id="add-sub-navBar">Add Sub-NavBar</button><br />- <fieldset>- <legend>Other Actions</legend> <div class="control-group">- <label class="control-label" for="remove-item"></label>- <div class="controls">- <button class="btn btn-danger" id="remove-item"><i class="icon-remove icon-white"></i> Remove Selected Item</button>- </div>- </div>- <div class="control-group"> <label class="control-label" for="saveChanges"></label> <div class="controls"> <button class="btn btn-success" id="saveChanges"><i class="icon-ok icon-white"></i> Save Changes</button>@@ -70,39 +63,52 @@ <fieldset> <legend>NavBar</legend>- <p><i>Drag and Drop to rearrange. Click to rename.</i></p>+ <p><i>Drag and Drop to rearrange. Right-click to rename or remove.</i></p> <div id="navBar"></div> </fieldset> </div> </%> where+ headers :: NavBar -> NavBarLinks -> GenChildList (Clck ClckURL) headers currentNavBar navBarLinks = do navBarUpdate <- showURL (Admin NavBarPost) <%>- <script type="text/javascript" src="/jstree/jquery.jstree.js" ></script>+ <link rel="stylesheet" href="/jstree/themes/default/style.min.css" />+ <script type="text/javascript" src="/jstree/jstree.min.js" ></script> <% [$jmacro|- function !doubleClickCB(e, dt) {- alert(dt.rslt.o);+// function !doubleClickCB(e, dt) {+// alert(dt.rslt.o); // navBar.rename(d.rslt);- };+// }; $(document).ready(function ()- { $("#navBar").jstree(`(jstree currentNavBar)`);- var !navBar = $.jstree._reference("#navBar");- $("#navBar").bind("select_node.jstree", function(e, d) { $("#navBar").jstree("rename", d.inst.o); } );-- // click elsewhere in document to unselect nodes- $(document).bind("click", function (e) {- if(!$(e.target).parents(".jstree:eq(0)").length) {- $.jstree._focused().deselect_all();- }- });-- `(initializeDropDowns navBarLinks)`;- `(removeItem)`;- `(saveChanges navBarUpdate)`;- });+ { $("#navBar").jstree({ 'core' :+ { 'data' : `(navBarToJSTree currentNavBar)`+ , 'themes' : { 'variant' : 'large' }+ , 'check_callback' : true+ }+ , 'contextmenu' :+ { 'items' : function (o, cb) {+ var items = $.jstree.defaults.contextmenu.items(o, cb);+ return { 'rename' : items.rename+ , 'remove' : items.remove+ };+ }+ }+ , 'types' :+ { 'target' :+ { 'icon' : 'icon-black icon-bookmark'+ , 'max_children' : 0+ }+ }+ , 'plugins' : [ 'contextmenu', 'dnd', 'types' ]+ }); + var !navBar = $.jstree.reference("#navBar");+ `(initializeDropDowns navBarLinks)`;+ `(removeItem)`;+ `(saveChanges navBarUpdate)`;+ }); |] %> </%>@@ -128,6 +134,7 @@ option.text(navBarLinks[p].pluginName); pluginList.append(option); }+ populateLinks(0); pluginList.change(function() { populateLinks($(this).val()); }); @@ -135,25 +142,28 @@ $("#add-link").click(function () { var indexes = navBarItemList.val().split(','); var navBarItem = navBarLinks[indexes[0]].pluginLinks[indexes[1]];- var entry = { 'state' : 'open'- , 'data' : { 'title' : navBarItem.navBarItemName }- , 'attr' : { 'rel' : 'target' }- , 'metadata'- : { 'link' : { 'navBarName' : navBarItem.navBarItemName- , 'navBarLink' : navBarItem.navBarItemLink- }- }++ var entry = { 'state' : { 'opened' : true }+ , 'text' : navBarItem.navBarItemName+ , 'type' : 'target'+ , 'a_attr' : { 'rel' : 'target' }+ , 'data' :+ { 'link' :+ { 'navBarName' : navBarItem.navBarItemName+ , 'navBarLink' : navBarItem.navBarItemLink+ }+ } };- navBar.create(null, "last", entry , null, true);+ navBar.create_node(null, entry, "last", null, false); }); |] -saveChanges :: Text -> JStat+saveChanges :: T.Text -> JStat saveChanges navBarUpdateURL = [$jmacro| $("#saveChanges").click(function () {- var tree = $("#navBar").jstree("get_json", -1);+ var tree = navBar.get_json('#'); // $("#navBar").jstree("get_json", -1); var json = JSON.stringify(tree); console.log(json); $.post(`(navBarUpdateURL)`, { tree : json });@@ -172,21 +182,21 @@ }); |] -jstree :: NavBar -> Value-jstree navBar =- object [ "types" .=- object [ "types" .=- object [ "root" .=- object [ "max_children" .= (-1 :: Int)- ]- , "navBar" .=- object [ "max_children" .= (-1 :: Int)- ]- , "target" .=- object [ "max_children" .= (0 :: Int)- , "icon" .= False- ]+ {-+ object [ "core" .=+ object [ "data" .= navBarToJSTree navBar+ ]+ , "types" .=+ object [ "#" .=+ object [ "max_children" .= (-1 :: Int) ]+ , "navBar" .=+ object [ "max_children" .= (-1 :: Int)+ ]+ , "target" .=+ object [ "max_children" .= (0 :: Int)+ , "icon" .= False+ ] ] , "dnd" .= object [ "drop_target" .= False@@ -195,17 +205,27 @@ , "ui" .= object [ "initially_select" .= ([ "tree-root" ] :: [String]) ]- , "json_data" .= navBarToJSTree navBar , "plugins" .= ([ "themes", "ui", "crrm", "types", "json_data", "dnd" ] :: [String]) ]--navBarToJSTree :: NavBar -> Value+-}+navBarToJSTree :: NavBar -> [Value] navBarToJSTree (NavBar items) =- object [ "data" .= (toJSON $ map navBarItemToJSTree items)- ]+ map navBarItemToJSTree items navBarItemToJSTree :: NavBarItem -> Value navBarItemToJSTree (NBLink NamedLink{..}) =+ [aesonQQ|+ { text : #{namedLinkTitle}+ , type : "target"+ , a_attr : { rel : "target" }+ , data : { link :+ { navBarLink : #{namedLinkURL}+ }+ }++ } |]+-- toJSON namedLinkTitle+ {- object [ "data" .= object [ "title" .= namedLinkTitle ]@@ -218,7 +238,25 @@ ] ] ]-+-}+{-+jstree :: NavBar -> Value+jstree navBar = -- #{navBarToJSTree navBar}+ [aesonQQ|+ { core :+ { data : []+ , themes : { variant : "large" }+ , check_callback : true+ }+ , types :+ { target :+ { icon : "glyphicon glyphicon-flash"+ , max_children : 0+ }+ }+ , plugins : ["contextmenu", "dnd", "types"]+ } |]+-} navBarPost :: Clck ClckURL Response navBarPost = do t <- lookBS "tree"@@ -227,7 +265,7 @@ -- liftIO $ print mu case mu of Nothing ->- do internalServerError $ toResponse ("navBarPost: failed to decode JSON data" :: Text)+ do internalServerError $ toResponse ("navBarPost: failed to decode JSON data" :: T.Text) (Just (NavBarUpdate u)) -> do update (SetNavBar u) ok $ toResponse ()@@ -239,9 +277,9 @@ instance FromJSON NavBarItem where parseJSON (Object o) =- do ttl <- o .: "data"- meta <- o .: "metadata"- link <- meta .: "link"+ do ttl <- o .: "text"+ meta <- o .: "data"+ link <- meta .: "link" navBarLink <- link .: "navBarLink" let nl = NamedLink ttl navBarLink return (NBLink nl)
@@ -1,25 +1,31 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards, TemplateHaskell #-}+{-# LANGUAGE CPP, DeriveGeneric, DeriveDataTypeable, OverloadedStrings, RecordWildCards, TemplateHaskell, FlexibleContexts, UndecidableInstances #-} module Clckwrks.NavBar.Types where import Clckwrks.Types (NamedLink(..)) import Data.Aeson (ToJSON(..), (.=), object) import Data.Data (Data, Typeable)-import Data.SafeCopy (base, deriveSafeCopy)+import Data.SafeCopy (SafeCopy(..), base, contain, deriveSafeCopy, getSafePut, getSafeGet)+import Data.Serialize (label, putWord8, getWord8) import Data.Text (Text)+import GHC.Generics (Generic) newtype NavBar = NavBar { navBarItems :: [NavBarItem] }- deriving (Eq, Read, Show, Data, Typeable)--+ deriving (Eq, Read, Show, Data, Typeable, Generic) data NavBarItem = NBLink NamedLink | NBSubNavBar Text NavBar- deriving (Eq, Read, Show, Data, Typeable)+ deriving (Eq, Read, Show, Data, Typeable, Generic)++#if __GLASGOW_HASKELL >= __900__+instance SafeCopy NavBar where version = 1+instance SafeCopy NavBarItem where version = 1+#else $(deriveSafeCopy 1 'base ''NavBar) $(deriveSafeCopy 1 'base ''NavBarItem)+#endif newtype NavBarLinks = NavBarLinks [(String, [NamedLink])] deriving (Eq, Read, Show, Data, Typeable)@@ -30,4 +36,3 @@ object [ "pluginName" .= plugName , "pluginLinks" .= map toJSON links ]) navBarLinks-
Clckwrks/Plugin.hs view
@@ -27,7 +27,7 @@ clckInit :: ClckPlugins -> IO (Maybe Text) clckInit plugins =- do (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)+ do ~(Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin) addNavBarCallback plugins clckMenuCallback addHandler plugins (pluginName clckPlugin) (clckHandler clckShowFn) return Nothing@@ -35,26 +35,27 @@ addClckAdminMenu :: ClckT url IO () addClckAdminMenu = do p <- plugins <$> get- (Just clckShowURL) <- getPluginRouteFn p (pluginName clckPlugin)+ ~(Just clckShowURL) <- getPluginRouteFn p (pluginName clckPlugin) addAdminMenu ( "Profile" , [ (Set.fromList [Administrator, Visitor], "Edit Your Profile" , clckShowURL (Profile EditProfileData) []) ] ) addAdminMenu ( "Clckwrks"- , [ (Set.singleton Administrator, "Console" , clckShowURL (Admin Console) [])- , (Set.singleton Administrator, "Edit Settings", clckShowURL (Admin EditSettings) [])- , (Set.singleton Administrator, "Edit Nav Bar" , clckShowURL (Admin EditNavBar) [])+ , [ (Set.singleton Administrator, "Console" , clckShowURL (Admin Console) [])+ , (Set.singleton Administrator, "Edit Settings" , clckShowURL (Admin EditSettings) [])+ , (Set.singleton Administrator, "Edit Nav Bar" , clckShowURL (Admin EditNavBar) [])+ , (Set.singleton Administrator, "System Emails" , clckShowURL (Admin SystemEmails) []) ] ) clckPlugin :: Plugin ClckURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt clckPlugin = Plugin- { pluginName = "clck"- , pluginInit = clckInit- , pluginDepends = []- , pluginToPathInfo = toPathInfo- , pluginPostHook = addClckAdminMenu+ { pluginName = "clck"+ , pluginInit = clckInit+ , pluginDepends = []+ , pluginToPathSegments = toPathSegments+ , pluginPostHook = addClckAdminMenu } plugin :: ClckPlugins
Clckwrks/ProfileData/API.hs view
@@ -1,28 +1,65 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Clckwrks.ProfileData.API- ( getProfileData- , getUsername+ ( getDisplayName+ , getProfileData+ , getUserRoles+ , requiresRole+ , requiresRole_ , whoami+ , Role(..) ) where import Clckwrks.Acid (Acid(..)) import Clckwrks.Monad+import Clckwrks.URL (ClckURL)+import {-# SOURCE #-} Clckwrks.Authenticate.Plugin (getUserId) import Clckwrks.ProfileData.Acid import Clckwrks.ProfileData.Types-import Control.Applicative ((<$>))-import Control.Monad.State (get)-import Data.Text (Text)-import Happstack.Auth (UserId(..))+import Clckwrks.Unauthorized (unauthorizedPage)+import Control.Applicative ((<$>))+import Control.Monad.State (get)+import Control.Monad.Trans (MonadIO)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Data.UserId (UserId(..))+import Happstack.Authenticate.Core (Username(..))+import Happstack.Server (Happstack, askRq, escape, rqUri, rqQuery)+import Web.Routes (RouteT(..)) -getProfileData :: UserId -> Clck url (Maybe ProfileData)+getProfileData :: UserId -> Clck url ProfileData getProfileData uid = query (GetProfileData uid) -getUsername :: UserId -> Clck url (Maybe Text)-getUsername uid =- query (GetUsername uid)+getDisplayName :: UserId -> Clck url (Maybe DisplayName)+getDisplayName uid = displayName <$> query (GetProfileData uid) whoami :: Clck url (Maybe UserId)-whoami =- do -- Acid{..} <- acidState <$> get- getUserId+whoami = getUserId +requiresRole_ :: (Happstack m) => (ClckURL -> [(Text, Maybe Text)] -> Text) -> Set Role -> url -> ClckT u m url+requiresRole_ showFn role url =+ ClckT $ RouteT $ \_ -> unRouteT (unClckT (requiresRole role url)) showFn++requiresRole :: (Happstack m) => Set Role -> url -> ClckT ClckURL m url+requiresRole role url =+ do mu <- getUserId+ case mu of+ Nothing ->+ do rq <- askRq+ escape $ do setRedirectCookie (rqUri rq ++ rqQuery rq)+ -- FIXME; redirect after login+ unauthorizedPage ("You do not have permission to view this page." :: TL.Text)+-- seeOtherURL (Auth $ AuthURL A_Login)+ (Just uid) ->+ do r <- query (HasRole uid role)+ if r+ then return url+ else escape $ unauthorizedPage ("You do not have permission to view this page." :: TL.Text)++getUserRoles :: (Happstack m, MonadIO m) => ClckT u m (Set Role)+getUserRoles =+ do mu <- getUserId+ case mu of+ Nothing -> return (Set.singleton Visitor)+ (Just u) -> query (GetRoles u)
Clckwrks/ProfileData/Acid.hs view
@@ -2,33 +2,29 @@ module Clckwrks.ProfileData.Acid ( ProfileDataState(..) , initialProfileDataState- , ProfileDataError(..)- , profileDataErrorStr , SetProfileData(..) , GetProfileData(..) , NewProfileData(..)- , GetUsername(..)- , GetUserIdUsernames(..)+ , UpdateProfileData(..) , HasRole(..) , GetRoles(..) , AddRole(..) , RemoveRole(..)- , UsernameForId(..) ) where -import Clckwrks.ProfileData.Types (ProfileData(..), Role(..), Username(..))-import Control.Applicative ((<$>))-import Control.Monad.Reader (ask)-import Control.Monad.State (get, put)-import Data.Acid (Update, Query, makeAcidic)-import Data.Data (Data, Typeable)-import Data.IxSet (IxSet, (@=), empty, getOne, insert, updateIx, toList)-import Data.SafeCopy (base, deriveSafeCopy)-import qualified Data.Set as Set-import Data.Set (Set)-import Data.Text (Text)-import qualified Data.Text as Text-import Happstack.Auth (UserId(..))+import Clckwrks.ProfileData.Types (ProfileData(..), Role(..), defaultProfileDataFor)+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put)+import Data.Acid (Update, Query, makeAcidic)+import Data.Data (Data, Typeable)+import Data.IxSet (IxSet, (@=), empty, getOne, insert, updateIx, toList)+import Data.SafeCopy (base, deriveSafeCopy)+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.UserId (UserId(..)) data ProfileDataState = ProfileDataState { profileData :: IxSet ProfileData@@ -40,43 +36,20 @@ initialProfileDataState :: ProfileDataState initialProfileDataState = ProfileDataState { profileData = empty } -data ProfileDataError- = UsernameAlreadyInUse- deriving (Eq, Ord, Read, Show, Data, Typeable)-$(deriveSafeCopy 0 'base ''ProfileDataError)--profileDataErrorStr :: ProfileDataError -> String-profileDataErrorStr UsernameAlreadyInUse = "Username already in use."--checkInvariants :: ProfileDataState -> ProfileData -> Maybe ProfileDataError-checkInvariants pds@ProfileDataState{..} pd =- case getOne $ profileData @= (Username $ username pd) of- (Just existingPd)- | ((username existingPd) == (username pd)) &&- ((username pd) /= Text.pack "Anonymous") &&- (not $ Text.null (username pd)) ->- (Just UsernameAlreadyInUse)- _ ->- Nothing-- setProfileData :: ProfileData- -> Update ProfileDataState (Maybe ProfileDataError)+ -> Update ProfileDataState () setProfileData pd = do pds@(ProfileDataState{..}) <- get- case checkInvariants pds pd of- (Just err) -> return (Just err)- Nothing ->- do put $ pds { profileData = updateIx (dataFor pd) pd profileData }- return Nothing-+ put $ pds { profileData = updateIx (dataFor pd) pd profileData } getProfileData :: UserId- -> Query ProfileDataState (Maybe ProfileData)+ -> Query ProfileDataState ProfileData getProfileData uid = do ProfileDataState{..} <- ask- return $ getOne $ profileData @= uid+ case getOne $ profileData @= uid of+ (Just pd) -> return pd+ Nothing -> return (defaultProfileDataFor uid) updateProfileData :: ProfileData -> Update ProfileDataState ()@@ -90,50 +63,37 @@ modifyProfileData fn uid = do ps@(ProfileDataState {..}) <- get case getOne $ profileData @= uid of- Nothing -> return ()+ Nothing ->+ do let pd' = fn (defaultProfileDataFor uid)+ put ps { profileData = insert pd' profileData } (Just pd) ->- do let pd' = fn pd- put ps { profileData = updateIx (dataFor pd') pd' profileData }+ do let pd' = fn pd+ put ps { profileData = updateIx (dataFor pd') pd' profileData } ++ -- | 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'--getUsername :: UserId- -> Query ProfileDataState (Maybe Text)-getUsername uid =- fmap username <$> getProfileData uid---- | get all the users-getUserIdUsernames :: Query ProfileDataState [(UserId, Text)]-getUserIdUsernames =- do pds <- profileData <$> ask- return $ map (\pd -> (dataFor pd, username pd)) (toList pds)+ return (pd, True)+ (Just pd') -> return (pd', False) getRoles :: UserId- -> Query ProfileDataState (Maybe (Set Role))+ -> Query ProfileDataState (Set Role) getRoles uid =- do mp <- getProfileData uid- case mp of- Nothing -> return Nothing- (Just profile) ->- return (Just $ roles profile)+ do profile <- getProfileData uid+ return (roles profile) hasRole :: UserId -> Set Role -> Query ProfileDataState Bool hasRole uid role =- do mp <- getProfileData uid- case mp of- Nothing -> return False- (Just profile) ->- return (not $ Set.null $ role `Set.intersection` roles profile)+ do profile <- getProfileData uid+ return (not $ Set.null $ role `Set.intersection` roles profile) addRole :: UserId -> Role@@ -151,30 +111,13 @@ where fn profileData = profileData { roles = Set.delete role (roles profileData) } -usernameForId :: UserId- -> Query ProfileDataState (Maybe Text)-usernameForId uid =- do ProfileDataState{..} <- ask- case getOne $ profileData @= uid of- Nothing -> return Nothing- (Just pd) -> return $ Just $ username pd--dataForUsername :: Text -- ^ username- -> Query ProfileDataState (Maybe ProfileData)-dataForUsername uname =- do ProfileDataState{..} <- ask- return $ getOne $ profileData @= (Username uname)- $(makeAcidic ''ProfileDataState [ 'setProfileData , 'getProfileData , 'newProfileData- , 'getUsername- , 'getUserIdUsernames+ , 'updateProfileData , 'getRoles , 'hasRole , 'addRole , 'removeRole- , 'usernameForId- , 'dataForUsername ])
+ Clckwrks/ProfileData/EditNewProfileData.hs view
@@ -0,0 +1,60 @@+{-# 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.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..))+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..))+import Clckwrks.ProfileData.EditProfileData(profileDataFormlet)+import Control.Monad.State (get)+import Control.Monad.Trans (liftIO)+import qualified Data.Acid as Acid+import Data.Text (pack)+import qualified Data.Text as Text+import Data.Text.Lazy (Text)+import Data.Maybe (fromMaybe)+import Data.UserId (UserId)+import Happstack.Authenticate.Core (Email(..), User(..), GetUserByUserId(..), UpdateUser(..))+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+import Web.Plugins.Core (Plugin(..), getPluginState)++-- 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 -- pd <- query (GetProfileData uid)+ p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ ~(Just user) <- liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid)+ pd <- query (GetProfileData uid)+ action <- showURL here+ emptyTemplate "Edit Profile Data" () $+ <%>+ <% reform (form action) "epd" updated Nothing (profileDataFormlet user 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/EditProfileData.hs view
@@ -1,17 +1,28 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-} module Clckwrks.ProfileData.EditProfileData where import Clckwrks-import Clckwrks.Admin.Template (template)-import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)-import Data.Text (Text, pack)-import Data.Maybe (fromMaybe)-import qualified Data.Text as Text-import Happstack.Auth (UserId)-import Text.Reform ((++>), mapView, transformEitherM)-import Text.Reform.HSP.Text (form, inputText, inputSubmit, label, fieldset, ol, li, errorList, setAttrs)-import Text.Reform.Happstack (reform)+import Clckwrks.Monad (plugins)+import Clckwrks.Admin.Template (template)+import Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..))+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..))+import Control.Monad.State (get)+import Control.Monad.Trans (liftIO)+import qualified Data.Acid as Acid+import Data.Text (pack)+import qualified Data.Text as Text+import Data.Text.Lazy (Text)+import Data.Maybe (fromMaybe)+import Data.UserId (UserId)+import Happstack.Authenticate.Core (Email(..), User(..), GetUserByUserId(..), UpdateUser(..))+import Language.Haskell.HSX.QQ (hsx)+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+import Web.Plugins.Core (Plugin(..), getPluginState) -- FIXME: this currently uses the admin template. Which is sort of right, and sort of not. @@ -19,43 +30,49 @@ editProfileDataPage here = do mUid <- getUserId case mUid of- Nothing -> internalServerError $ toResponse $ "Unable to retrieve your userid"+ 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- template "Edit Profile Data" () $- <%>- <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>- </%>+ do -- pd <- query (GetProfileData uid)+ p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ ~(Just user) <- liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid)+ pd <- query (GetProfileData uid)+ action <- showURL here+ template "Edit Profile Data" () $ [hsx|+ <%>+ <% reform (form action) "epd" updated Nothing (profileDataFormlet user pd) %>+-- <div ng-controller="UsernamePasswordCtrl">+-- <up-change-password />+-- </div>+ </%> |] where updated :: () -> Clck ProfileDataURL Response updated () = do seeOtherURL here -profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL ()-profileDataFormlet pd@ProfileData{..} =+profileDataFormlet :: User -> ProfileData -> ClckForm ProfileDataURL ()+profileDataFormlet u@User{..} pd = divHorizontal $ errorList ++>- ((,) <$> (divControlGroup (label' "Username" ++> (divControls (inputText username))))- <*> (divControlGroup (label'" Email (optional)" ++> (divControls (inputText (fromMaybe Text.empty email)))))- <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` ("class" := "btn")))))+ ((,) <$> (divControlGroup (label' "Email" ++> (divControls (inputText (maybe Text.empty _unEmail _email)))))+ <*> (divControlGroup (label' "DisplayName" ++> (divControls (inputText (maybe Text.empty unDisplayName (displayName pd))))))+ <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` (("class" := "btn") :: Attr Text Text))))+ ) `transformEitherM` updateProfileData- where- label' str = (label str `setAttrs` [("class":="control-label")])- divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])- divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])- divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])+ where+ label' :: Text -> ClckForm ProfileDataURL ()+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])+ divHorizontal = mapView (\xml -> [[hsx|<div class="form-horizontal"><% xml %></div>|]])+ divControlGroup = mapView (\xml -> [[hsx|<div class="control-group"><% xml %></div>|]])+ divControls = mapView (\xml -> [[hsx|<div class="controls"><% xml %></div>|]]) - updateProfileData :: (Text, Text) -> Clck ProfileDataURL (Either ClckFormError ())- updateProfileData (usrnm, eml) =- do let newPd = pd { username = usrnm- , email = if Text.null eml then Nothing else (Just eml)- }- merr <- update (SetProfileData newPd)- case merr of- Nothing -> return $ Right ()- (Just err) -> return $ Left (PDE err)+ updateProfileData :: (Text.Text, Text.Text) -> Clck ProfileDataURL (Either ClckFormError ())+ updateProfileData (eml, dn) =+ do let user = u { _email = if Text.null eml then Nothing else (Just (Email eml))+ }+ p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ liftIO $ Acid.update (acidStateAuthenticate aps) (UpdateUser user)+ pd <- query (GetProfileData _userId)+ update (SetProfileData (pd { displayName = if Text.null dn then Nothing else Just (DisplayName dn) }))+ pure $ Right ()
Clckwrks/ProfileData/EditProfileDataFor.hs view
@@ -1,57 +1,146 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-} module Clckwrks.ProfileData.EditProfileDataFor where import Clckwrks-import Clckwrks.Admin.Template (template)-import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)-import Data.Maybe (fromMaybe)-import Data.Set as Set-import Data.Text (Text, pack)-import qualified Data.Text as Text-import Happstack.Auth (UserId)-import Text.Reform ((++>), transformEitherM)+import Clckwrks.Admin.Template (template)+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..))+import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..))+import Clckwrks.Authenticate.URL (AuthURL(ResetPassword))+import Control.Monad.State (get)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Set as Set+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as LT+import qualified Data.Text as Text+import Data.UserId (UserId)++import Language.Haskell.HSX.QQ (hsx)+import Happstack.Authenticate.Core (Email(..), GetUserByUserId(..), User(..), UserId(..), Username(..))+import Happstack.Authenticate.Password.Core (SetPassword(..), mkHashedPass, resetTokenForUserId)+import HSP.XMLGenerator+import HSP.XML+import System.FilePath ((</>))+import Text.Reform ((++>), mapView, transformEitherM) import Text.Reform.Happstack (reform)-import Text.Reform.HSP.Text (inputCheckboxes, inputText, label, inputSubmit, fieldset, ol, li, form)+import Text.Reform.HSP.Text (inputCheckboxes, inputPassword, inputText, labelText, inputSubmit, fieldset, ol, li, form, setAttrs)+import Web.Plugins.Core (getConfig, getPluginState, getPluginRouteFn) editProfileDataForPage :: ProfileDataURL -> UserId -> Clck ProfileDataURL Response editProfileDataForPage here uid =- do mpd <- query (GetProfileData uid)- case mpd of+ do pd <- query (GetProfileData uid)+ mu <- query (GetUserByUserId uid)+ case mu of Nothing ->- do notFound ()- template "Edit Profile Data" () $- <p>No profile data for <% show uid %>.</p>- (Just pd) ->- do action <- showURL here- template "Edit Profile Data" () $+ template "Edit Profile Data" () $+ [hsx|+ <div>Invalid UserId <% show uid %></div>+ |]+ (Just u) ->+ do action <- showURL here+ template "Edit Profile Data" () $ [hsx|+ <div>+ <h2>User Info</h2>+ <dl>+ <dt>UserId</dt> <dd><% show $ _unUserId $ _userId u %></dd>+ <dt>Username</dt><dd><% _unUsername $ _username u %></dd>+ <dt>Email</dt> <dd><% maybe Text.empty _unEmail (_email u) %></dd>+ </dl>+ <h2>Roles</h2> <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>-+ <h2>Update User's Password</h2>+ <% reform (form action) "pf" updated Nothing (passwordForFormlet uid) %>+ <h2>Generate Password Reset Link</h2>+ <% reform (form action) "prl" (generateResetLink uid) Nothing generateResetLinkFormlet %>+ </div>+ |] where updated :: () -> Clck ProfileDataURL Response updated () = do seeOtherURL here + generateResetLink :: UserId -> Maybe Text.Text -> Clck ProfileDataURL Response+ generateResetLink uid _ =+ do p <- plugins <$> get+ ~(Just aps) <- getPluginState p "authenticate"+ ~(Just authShowURL) <- getPluginRouteFn p "authenticate"+ cc <- getConfig p+ let basePath = maybe "_state" (\top -> top </> "_state") (clckTopDir cc)+ baseUri = case calcTLSBaseURI cc of+ Nothing -> calcBaseURI cc+ (Just b) -> b++ resetLink = (authShowURL ResetPassword []) <> "/#"+ eResetTokenLink <- liftIO $ resetTokenForUserId resetLink (acidStateAuthenticate aps) (acidStatePassword aps) uid+ case eResetTokenLink of+ (Left e) -> template "Reset Password Link" () $+ [hsx|+ <div>+ <h2>Reset Password Link Error</h2>+ <% show e %>+ </div>+ |]+ (Right lnk) ->+ template "Reset Password Link" () $+ [hsx|+ <div>+ <h2>Reset Password Link</h2>+ <p>Share this link with the user</p>+ <% lnk %>+ </div>+ |]++generateResetLinkFormlet :: ClckForm ProfileDataURL (Maybe Text.Text)+generateResetLinkFormlet =+ do (fieldset $+ (divControlGroup $ divControls $ inputSubmit "Generate Change Password Link" `setAttrs` [("class" := "btn") :: Attr Text Text]))+ where+ divControlGroup = mapView (\xml -> [[hsx|<div class="control-group"><% xml %></div>|]])+ divControls = mapView (\xml -> [[hsx|<div class="controls"><% xml %></div>|]])+++passwordForFormlet :: UserId -> ClckForm ProfileDataURL ()+passwordForFormlet userid =+ (fieldset $+ (divControlGroup $+ (divControls (label' "new password" ++> inputPassword))+ )+ <* (divControlGroup $ divControls $ inputSubmit "Change Password" `setAttrs` [("class" := "btn") :: Attr Text Text])+ ) `transformEitherM` updatePassword+ where+ label' :: Text -> ClckForm ProfileDataURL ()+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])+-- divHorizontal = mapView (\xml -> [[hsx|<div class="form-horizontal"><% xml %></div>|]])+ divControlGroup = mapView (\xml -> [[hsx|<div class="control-group"><% xml %></div>|]])+ divControls = mapView (\xml -> [[hsx|<div class="controls"><% xml %></div>|]])++ updatePassword :: Text.Text -> Clck ProfileDataURL (Either ClckFormError ())+ updatePassword newPw+ | Text.null newPw = pure (Right ())+ | otherwise =+ do hp <- mkHashedPass newPw+ update (SetPassword userid hp)+ pure (Right ())+ profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL () profileDataFormlet pd@ProfileData{..} = (fieldset $- ol $- ((,,) <$> (li $ label "username:") ++> (li $ inputText username)- <*> (li $ label "email (optional):") ++> (li $ inputText (fromMaybe Text.empty email))- <*> (li $ label "roles:") ++> (li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles))- <* inputSubmit (pack "update")- )+ (divControlGroup $+ (divControls (inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) `setAttrs` (("class" := "form-check") :: Attr Text Text)))+ <* (divControlGroup $ divControls $ inputSubmit "Update Roles" `setAttrs` [("class" := "btn") :: Attr Text Text]) ) `transformEitherM` updateProfileData where- updateProfileData :: (Text, Text, [Role]) -> Clck ProfileDataURL (Either ClckFormError ())- updateProfileData (usrnm, eml, roles') =- if Text.null usrnm- then do return (Left EmptyUsername)- else do let newPd = pd { username = usrnm- , email = if Text.null eml then Nothing else (Just eml)- , roles = Set.fromList roles'- }- merr <- update (SetProfileData newPd)- case merr of- Nothing -> return $ Right ()- (Just err) -> return $ Left (PDE err)+ label' :: Text -> ClckForm ProfileDataURL ()+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])+-- divHorizontal = mapView (\xml -> [[hsx|<div class="form-horizontal"><% xml %></div>|]])+ divControlGroup = mapView (\xml -> [[hsx|<div class="control-group"><% xml %></div>|]])+ divControls = mapView (\xml -> [[hsx|<div class="controls"><% xml %></div>|]])++ updateProfileData :: [Role] -> Clck ProfileDataURL (Either ClckFormError ())+ updateProfileData roles' =+ do let newPd = pd { roles = Set.fromList roles'+ }+ update (SetProfileData newPd)+ pure (Right ())++-- ((li $ labelText "roles:") ++> ((li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) `setAttrs` (("class" := "form-check") :: Attr Text Text))
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@@ -19,13 +20,21 @@ case mUserId of Nothing -> internalServerError $ toResponse $ "not logged in." (Just userId) ->- do let profileData = emptyProfileData { dataFor = userId- , roles = singleton Visitor- }- update (NewProfileData profileData)- seeOtherURL EditProfileData+ do (_, new) <- update (NewProfileData (defaultProfileDataFor userId))+ 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/Types.hs view
@@ -1,25 +1,28 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeFamilies #-} module Clckwrks.ProfileData.Types- ( ProfileData(..)+ ( DisplayName(..)+ , ProfileData(..) , Role(..)+ , defaultProfileDataFor , emptyProfileData , Username(..) ) where -import Happstack.Auth (UserId(..)) import Data.Data (Data, Typeable) import Data.IxSet (Indexable(..), ixSet, ixFun) import Data.IxSet.Ix (Ix) import Data.Map (Map, empty) import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)-import Data.Set (Set, empty)+import Data.Set (Set, empty, singleton) import Data.Text (Text, empty) import Data.Typeable (Typeable)+import Data.UserId (UserId(..))+import GHC.Generics (Generic) data Role_001 = Administrator_001 | Visitor_001- deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded)+ deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded, Generic) $(deriveSafeCopy 1 'base ''Role_001) data Role@@ -27,7 +30,7 @@ | Visitor | Moderator | Editor- deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded)+ deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded, Generic) $(deriveSafeCopy 2 'extension ''Role) instance Migrate Role where@@ -35,33 +38,67 @@ migrate Administrator_001 = Administrator migrate Visitor_001 = Visitor +newtype Username = Username { unUsername :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +newtype DisplayName = DisplayName { unDisplayName :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+$(deriveSafeCopy 1 'base ''DisplayName)++data ProfileData_1 = ProfileData_1+ { dataFor_1 :: UserId+ , username_1 :: Text -- ^ now comes from happstack-authenticate+ , email_1 :: Maybe Text -- ^ now comes from happstack-authenticate+ , roles_1 :: Set Role+ , attributes_1 :: Map Text Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)++$(deriveSafeCopy 1 'base ''ProfileData_1)++data ProfileData_2 = ProfileData_2+ { dataFor_2 :: UserId+ , roles_2 :: Set Role+ , attributes_2 :: Map Text Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)++$(deriveSafeCopy 2 'extension ''ProfileData_2)++instance Migrate ProfileData_2 where+ type MigrateFrom ProfileData_2 = ProfileData_1+ migrate (ProfileData_1 df _ _ rs attrs) = ProfileData_2 df rs attrs+ data ProfileData = ProfileData- { dataFor :: UserId- , username :: Text- , email :: Maybe Text- , roles :: Set Role- , attributes :: Map Text Text+ { dataFor :: UserId+ , displayName :: Maybe DisplayName+ , roles :: Set Role+ , attributes :: Map Text Text }- deriving (Eq, Ord, Read, Show, Data, Typeable)+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) -$(deriveSafeCopy 1 'base ''ProfileData)+$(deriveSafeCopy 3 'extension ''ProfileData) +instance Migrate ProfileData where+ type MigrateFrom ProfileData = ProfileData_2+ migrate (ProfileData_2 df rs attrs) = ProfileData df Nothing rs attrs+ emptyProfileData :: ProfileData emptyProfileData = ProfileData- { dataFor = UserId 0- , username = Data.Text.empty- , email = Nothing- , roles = Data.Set.empty- , attributes = Data.Map.empty+ { dataFor = UserId 0+ , displayName = Nothing+ , roles = Data.Set.empty+ , attributes = Data.Map.empty } -newtype Username = Username { unUsername :: Text }- deriving (Eq, Ord, Read, Show, Data, Typeable)+defaultProfileDataFor :: UserId -> ProfileData+defaultProfileDataFor uid =+ emptyProfileData { dataFor = uid+ , roles = singleton Visitor+ } instance Indexable ProfileData where empty = ixSet [ ixFunS dataFor- , ixFunS $ Username . username ] where ixFunS :: (Ord b, Typeable b) => (a -> b) -> Ix a
Clckwrks/ProfileData/URL.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} module Clckwrks.ProfileData.URL where -import Data.Data (Data, Typeable)-import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy)-import Happstack.Auth (UserId)-import Web.Routes.TH (derivePathInfo)+import Data.Data (Data, Typeable)+import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy)+import Data.UserId (UserId)+import Web.Routes.TH (derivePathInfo) data ProfileDataURL = CreateNewProfileData | EditProfileData+ | EditNewProfileData | EditProfileDataFor UserId deriving (Eq, Ord, Read, Show, Data, Typeable)
Clckwrks/Route.hs view
@@ -2,17 +2,19 @@ module Clckwrks.Route where import Clckwrks+import Clckwrks.Acid (GetEnableOpenId(..)) import Clckwrks.Admin.Route (routeAdmin) import Clckwrks.BasicTemplate (basicTemplate)-import Clckwrks.Monad (calcTLSBaseURI, withAbs)+import Clckwrks.Monad (calcTLSBaseURI, withAbs, query)+import Clckwrks.ProfileData.API (requiresRole) import Clckwrks.ProfileData.Route (routeProfileData)+import Clckwrks.JS.Route (routeJS) import Control.Monad.State (MonadState(get)) import Data.Maybe (fromJust) import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text (Text, pack) import qualified Data.Text as Text-import Happstack.Auth (handleAuthProfile) import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile) import Network.URI (unEscapeString) import Paths_clckwrks (getDataDir)@@ -25,10 +27,12 @@ checkAuth url = case url of ThemeData{} -> return url+ ThemeDataNoEscape{} -> return url PluginData{} -> return url Admin{} -> requiresRole (Set.singleton Administrator) url- Auth{} -> return url+ JS {} -> 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 @@ -48,8 +52,20 @@ let fp'' = makeRelative "/" (unEscapeString fp') if not (isSafePath (splitDirectories fp'')) then notFound (toResponse ())- else serveFile (guessContentTypeM mimeTypes) (fp </> "data" </> fp'')+ else serveFile (guessContentTypeM mimeTypes) (fp </> fp'') + (ThemeDataNoEscape (NoEscape fp')) ->+ do p <- plugins <$> get+ mTheme <- getTheme p+ case mTheme of+ Nothing -> notFound $ toResponse ("No theme package is loaded." :: Text)+ (Just theme) ->+ do fp <- liftIO $ themeDataDir theme+ let fp'' = makeRelative "/" fp'+ if not (isSafePath (splitDirectories fp''))+ then notFound (toResponse ())+ else serveFile (guessContentTypeM mimeTypes) (fp </> fp'')+ (PluginData plugin fp') -> do pp <- liftIO getDataDir let fp'' = makeRelative "/" (unEscapeString fp')@@ -63,23 +79,6 @@ (Profile profileDataURL) -> do nestURL Profile $ routeProfileData profileDataURL - (Auth apURL) ->- do clckState <- get- cc <- getConfig (plugins clckState)- let go = do let Acid{..} = acidState clckState- u <- showURL $ Profile CreateNewProfileData- showClckURL <- askRouteFn- cs <- get- let template' ttl hdr bdy = withRouteClckT (const showClckURL) $ themeTemplate (plugins cs) (pack ttl) hdr bdy- withAbs $ nestURL Auth $ handleAuthProfile acidAuth acidProfile template' Nothing Nothing u apURL- case clckTLS cc of- Nothing -> go- (Just tlsSettings) ->- do secure <- rqSecure <$> askRq- if secure- then go- else do u <- rqUri <$> askRq- let sslU = ((Text.unpack $ fromJust $ calcTLSBaseURI cc) ++ u)- seeOther sslU (toResponse ())--+ (JS jsURL) ->+ do b <- query GetEnableOpenId+ nestURL JS $ routeJS b jsURL
Clckwrks/Server.hs view
@@ -3,85 +3,136 @@ import Clckwrks import Clckwrks.Admin.Route (routeAdmin)-import Clckwrks.Monad (ClckwrksConfig(..), TLSSettings(..), initialClckPluginsSt)+import Clckwrks.Monad (ClckwrksConfig(..), TLSSettings(..), calcBaseURI, calcTLSBaseURI, initialClckPluginsSt) -- import Clckwrks.Page.Acid (GetPageTitle(..), IsPublishedPage(..)) -- import Clckwrks.Page.Atom (handleAtomFeed) -- import Clckwrks.Page.PreProcess (pageCmd)-import Clckwrks.ProfileData.Route (routeProfileData) import Clckwrks.ProfileData.Types (Role(..)) import Clckwrks.ProfileData.URL (ProfileDataURL(..)) import Control.Arrow (second) import Control.Concurrent (forkIO, killThread)-import Control.Concurrent.STM (atomically, newTVar)+import Control.Concurrent.STM (atomically, newTVar, readTVar) import Control.Monad.State (get, evalStateT)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as LB+import Data.Acid.Advanced (query') import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (fromJust)+import Data.Maybe (fromJust, fromMaybe, isNothing) import Data.Monoid ((<>))+import qualified Data.ByteString.Lazy.UTF8 as UTF8+import Data.ByteString.Builder (toLazyByteString) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text-import qualified Data.UUID as UUID-import Happstack.Auth (handleAuthProfile)+import Data.Text.Encoding (decodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.UUID.Types as UUID import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)+import Happstack.Server.Internal.Multipart (simpleInput)+import Happstack.Server.Internal.Types (canHaveBody)+import Happstack.Server.Monads (askRq) import Happstack.Server.SimpleHTTPS (TLSConf(..), nullTLSConf, simpleHTTPS)-import Network.URI (unEscapeString)+import Happstack.Server.Types (Request(rqMethod))+import Network.HTTP.Types (encodePathSegments)+import Network.HTTP.Types.URI (renderQueryText) import System.FilePath ((</>), makeRelative, splitDirectories) import Web.Routes.Happstack (implSite)-import Web.Plugins.Core (Plugins, withPlugins, getPluginRouteFn, getPostHooks, serve)+import Web.Plugins.Core (Plugins(..), PluginsState(pluginsRewrite), Rewrite(Rewrite, Redirect), withPlugins, getPluginRouteFn, getPostHooks, serve) import qualified Paths_clckwrks as Clckwrks withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b-withClckwrks cc action =- withPlugins cc initialClckPluginsSt $ \plugins ->- withAcid (fmap (\top -> top </> "_state") (clckTopDir cc)) $ \acid ->- do u <- atomically $ newTVar 0- let clckState = ClckState { acidState = acid+withClckwrks cc action = do+ let top' = fmap (\top -> top </> "_state") (clckTopDir cc)+ withAcid top' $ \acid ->+ withPlugins cc (initialClckPluginsSt acid) $ \plugins -> do+ u <- atomically $ newTVar 0+ let clckState = ClckState { acidState = acid -- , currentPage = PageId 0- , uniqueId = u- , adminMenus = []- , enableAnalytics = clckEnableAnalytics cc- , plugins = plugins- }- action clckState+ , uniqueId = u+ , adminMenus = []+ , enableAnalytics = clckEnableAnalytics cc+ , plugins = plugins+ , requestInit = return ()+ }+ action clckState simpleClckwrks :: ClckwrksConfig -> IO () simpleClckwrks cc = withClckwrks cc $ \clckState ->- do (clckState', cc') <- (clckInitHook cc) (calcBaseURI cc) clckState cc+ do let baseURI =+ case calcTLSBaseURI cc of+ (Just baseUri) -> baseUri+ Nothing -> calcBaseURI cc+ (clckState', cc') <- (clckInitHook cc) baseURI clckState cc let p = plugins clckState' hooks <- getPostHooks p- (Just clckShowFn) <- getPluginRouteFn p "clck"+ ~(Just clckShowFn) <- getPluginRouteFn p "clck" let showFn = \url params -> clckShowFn url [] clckState'' <- execClckT showFn clckState' $ sequence_ hooks- httpTID <- forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'') mHttpsTID <- case clckTLS cc' of Nothing -> return Nothing (Just TLSSettings{..}) ->- do let tlsConf = nullTLSConf { tlsPort = clckTLSPort- , tlsCert = clckTLSCert- , tlsKey = clckTLSKey- }- tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'')- return (Just tid)+ case (clckTLSCert, clckTLSKey) of+ (Just certPath, Just keyPath) -> do+ let tlsConf = nullTLSConf { tlsPort = clckTLSPort+ , tlsCert = certPath+ , tlsKey = keyPath+ , tlsCA = clckTLSCA+ }+ tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'')+ return (Just tid)+ _ -> return Nothing+++ httpTID <- if isNothing mHttpsTID+ then forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'')+ else forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) forceHTTPS -- putStrLn "Server Now Listening For Requests." waitForTermination killThread httpTID maybe (return ()) killThread mHttpsTID where- handlers cc clckState =- do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6))+ handlers :: ClckwrksConfig -> ClckState -> ServerPart Response+ handlers cc clckState =+ do forceCanonicalHost+ req <- askRq+ when (canHaveBody (rqMethod req)) $+ do (p, mDisk, mRam, mHeader) <- query' (acidCore $ acidState clckState) GetBodyPolicy+ decodeBody (defaultBodyPolicy p mDisk mRam mHeader)+ requestInit clckState msum $ [ jsHandlers cc- , dir "favicon.ico" $ notFound (toResponse ()) , dir "static" $ (liftIO $ Clckwrks.getDataFileName "static") >>= serveDirectory DisableBrowsing []- , nullDir >> seeOther ("/page/view-page/1" :: String) (toResponse ()) -- FIXME: get redirect location from database+ , do nullDir+ mRR <- query' (acidCore . acidState $ clckState) GetRootRedirect+ seeOther (fromMaybe ("/page/view-page/1") mRR) (toResponse ()) -- FIXME: get redirect location from database , clckSite cc clckState ] + forceCanonicalHost :: ServerPart ()+ forceCanonicalHost =+ do rq <- askRq+ case getHeader "host" rq of+ Nothing -> return ()+ (Just hostBS) ->+ if (clckHostname cc == (B.unpack $ B.takeWhile (/= ':') hostBS))+ then return ()+ else escape $ seeOther ((if isSecure cc rq then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ())++ -- if https:// is available, then force it to be used.+ -- GET requests will be redirected automatically, POST, PUT, etc will be denied+ forceHTTPS :: ServerPart Response+ forceHTTPS =+ msum [ do method GET+ rq <- askRq+ seeOther ((fromJust $ calcTLSBaseURI cc) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ())+ , do forbidden (toResponse ("https:// required." :: Text))+ ]+ jsHandlers :: (Happstack m) => ClckwrksConfig -> m Response jsHandlers c = msum [ dir "jquery" $ serveDirectory DisableBrowsing [] (clckJQueryPath c)@@ -92,18 +143,63 @@ clckSite :: ClckwrksConfig -> ClckState -> ServerPart Response clckSite cc clckState =- do (Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck")- evalClckT clckShowFn clckState (pluginsHandler (plugins clckState))+ do ~(Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck")+ evalClckT clckShowFn clckState (pluginsHandler cc (plugins clckState)) -pluginsHandler :: (Functor m, ServerMonad m, FilterMonad Response m, MonadIO m) =>- Plugins theme (m Response) hook config ppm+pluginsHandler :: (Functor m, Happstack m, MonadIO m) =>+ ClckwrksConfig+ -> Plugins theme (m Response) hook config ppm -> m Response-pluginsHandler plugins =- do paths <- (map Text.pack . rqPaths) <$> askRq- case paths of- (p : ps) ->- do e <- liftIO $ serve plugins p ps- case e of- (Right c) -> c- (Left e) -> notFound $ toResponse e- _ -> notFound (toResponse ())+pluginsHandler cc plugins@(Plugins tvp) =+ do ps' <- liftIO $ atomically $ readTVar tvp+ req <- askRq+ let paths' = map Text.pack $ rqPaths req+ params'=+ let conv :: (String, Input) -> (Text, Maybe Text)+ conv (k, i) =+ case inputValue i of+ (Left _) -> (Text.pack k, Nothing)+ (Right bs) -> (Text.pack k, Just $ decodeUtf8With lenientDecode (LB.toStrict bs))+ in map conv (rqInputsQuery req)+ -- we figure out which plugin to call by looking at the+ -- first path segment in the url+ let cont paths =+ case paths of+ (p : ps) ->+ do e <- liftIO $ serve plugins p ps+ case e of+ (Right c) -> c+ (Left e) -> notFound $ toResponse e+ _ -> notFound (toResponse ())++ -- before we can figure out what the path segment is, we+ -- need to rewrite the URL.+ -- FIXME: Somewhat annoyingly, we rewrite the url and then+ -- throw out the results.+ case pluginsRewrite ps' of+ Nothing -> cont paths'+ (Just (mf, _)) ->+ let conv :: (Text, Maybe Text) -> (String, Input)+ conv (k, v) = (Text.unpack k, maybe (simpleInput "") (\v' -> simpleInput $ Text.unpack v') v)+ in do f <- liftIO mf+ case f paths' params' of+ (Just (Rewrite, paths, params)) ->+ let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params+ pi = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths)+ in+ localRq (\req -> req { rqQuery = UTF8.toString $ toLazyByteString $ renderQueryText True params+ , rqPaths = map Text.unpack paths+ , rqUri = Text.unpack $ (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> pi <> qry+ , rqInputsQuery = map conv params+ }) $ do -- rq <- askRq+ -- liftIO $ print rq+ cont paths+ (Just (Redirect mBaseURI, paths, params)) ->+ let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params+ pi = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths)+ in+ do -- liftIO $ putStrLn $ show $ rqQuery req+ escape $ seeOther ((fromMaybe (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) mBaseURI) <> pi <> qry) (toResponse ())+ Nothing -> cont paths'++-- (Redirect, paths) -> seeOther
Clckwrks/Types.hs view
@@ -6,21 +6,29 @@ , NamedLink(..) ) where +import Control.Applicative ((<$>)) import Data.Aeson (ToJSON(..), (.=), object) import Data.Data (Data, Typeable)-import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)+import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy, safeGet, safePut, contain) import Data.Text (Text)-import Data.UUID (UUID)+import qualified Data.Text.Encoding as T+import Data.UUID.Types (UUID)+import Data.UUID.Orphans () import HSP.Google.Analytics (UACCT) -- | 'SafeCopy' instances for some 3rd party types $(deriveSafeCopy 0 'base ''UACCT)-$(deriveSafeCopy 0 'base ''UUID) -- | at present this is only used by the menu editor newtype Prefix = Prefix { prefixText :: Text }- deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy)+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance SafeCopy Prefix where+ kind = base+ getCopy = contain $ (Prefix . T.decodeUtf8) <$> safeGet+ putCopy = contain . safePut . T.encodeUtf8 . prefixText+ errorTypeName _ = "Prefix" data Trust = Trusted -- ^ used when the author can be trusted (sanitization is not performed)
Clckwrks/URL.hs view
@@ -1,70 +1,39 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, TypeFamilies #-} module Clckwrks.URL ( ClckURL(..) , AdminURL(..)- , AuthURL(..)- , ProfileURL(..)- , AuthProfileURL(..)- , ProfileDataURL(..)+ , AuthenticateURL(..)+ , NoEscape(..) ) where import Clckwrks.Admin.URL (AdminURL(..))--- import Clckwrks.Page.Acid (PageId(..))--- import Clckwrks.Page.Types (Slug(..))+import Clckwrks.JS.URL (JSURL) import Clckwrks.ProfileData.URL (ProfileDataURL(..))-import Control.Applicative ((<$>))+import Control.Applicative ((<$>), many) import Data.Data (Data, Typeable) import Data.SafeCopy (Migrate(..), SafeCopy(..), base, deriveSafeCopy, extension)-import Data.Text (Text)-import Happstack.Auth (AuthURL(..), ProfileURL(..), AuthProfileURL(..), UserId)-import Happstack.Auth.Core.AuthURL (OpenIdURL, AuthMode, OpenIdProvider)+import Data.Text (Text, pack, unpack)+import Happstack.Authenticate.Core (AuthenticateURL(..))+import System.FilePath (joinPath, splitDirectories)+import Web.Routes (PathInfo(..), anySegment) import Web.Routes.TH (derivePathInfo)-{--data ClckURL_1- = ViewPage_1 PageId- | Blog_1- | AtomFeed_1- | ThemeData_1 FilePath- | PluginData_1 Text FilePath- | Admin_1 AdminURL- | Profile_1 ProfileDataURL- | Auth_1 AuthProfileURL++newtype NoEscape a = NoEscape a deriving (Eq, Ord, Data, Typeable, Read, Show)-$(deriveSafeCopy 1 'base ''ClckURL_1)--}++instance PathInfo (NoEscape String) where+ toPathSegments (NoEscape s) = map pack $ splitDirectories s+ fromPathSegments =+ do ps <- many anySegment+ return (NoEscape (joinPath $ map unpack ps))+ data ClckURL-{-- = ViewPage PageId- | ViewPageSlug PageId Slug- | Blog- | AtomFeed--}- = ThemeData FilePath+ = ThemeData String+ | ThemeDataNoEscape (NoEscape FilePath) | PluginData Text FilePath | Admin AdminURL | Profile ProfileDataURL- | Auth AuthProfileURL+ | JS JSURL deriving (Eq, Ord, Data, Typeable, Read, Show)-(deriveSafeCopy 3 'base ''ClckURL)-{--instance Migrate ClckURL where- type MigrateFrom ClckURL = ClckURL_1- migrate (ViewPage_1 pid) = ViewPage pid- migrate Blog_1 = Blog- migrate AtomFeed_1 = AtomFeed- migrate (ThemeData_1 fp) = ThemeData fp- migrate (PluginData_1 t f) = PluginData t f- migrate (Admin_1 u) = Admin u- migrate (Profile_1 pdu) = Profile pdu- migrate (Auth_1 apu) = Auth apu--}---- TODO: move upstream-$(deriveSafeCopy 1 'base ''AuthURL)-$(deriveSafeCopy 1 'base ''ProfileURL)-$(deriveSafeCopy 1 'base ''AuthProfileURL)-$(deriveSafeCopy 1 'base ''OpenIdURL)-$(deriveSafeCopy 1 'base ''AuthMode)-$(deriveSafeCopy 1 'base ''OpenIdProvider) $(derivePathInfo ''ClckURL)
Clckwrks/Unauthorized.hs view
@@ -1,17 +1,20 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, TypeFamilies #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Unauthorized ( unauthorizedPage ) where import Control.Applicative ((<$>))-import HSP+-- import HSP+import Data.Text.Lazy import Happstack.Server (Happstack, Response, ToMessage, toResponse, unauthorized)-import qualified HSX.XMLGenerator (XMLType)+import HSP.XML+import HSP.XMLGenerator unauthorizedPage :: ( Happstack m , XMLGenerator m+ , StringType m ~ Text , EmbedAsChild m msg , ToMessage (XMLType m) ) => msg -> m Response
− HSP/HTMLBuilder.hs
@@ -1,156 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.HTML--- Copyright : (c) Niklas Broberg, Jeremy Shaw 2008--- License : BSD-style (see the file LICENSE.txt)------ Maintainer : Niklas Broberg, nibro@cs.chalmers.se--- Stability : experimental--- Portability : Haskell 98------ Attempt to render XHTML as well-formed HTML 4.01:------ 1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>------ 2. the end tag is forbidden for some elements, for these we:------ * render only the open tag, e.g., \<br\>------ * throw an error if the tag contains children------ 3. optional end tags are always rendered------ Currently no validation is performed.-------------------------------------------------------------------------------module HSP.HTMLBuilder (- Style(..)- -- * Functions- , renderAsHTML- , htmlEscapeChars- ) where--import Data.List-import Data.Monoid (mappend, mconcat, mempty)-import Data.Text.Lazy (unpack)-import Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText)-import HSP.XML-import HSP.XML.PCDATA(escaper)---- | Pretty-prints HTML values.------ Error Handling:------ Some tags (such as img) can not contain children in HTML. However,--- there is nothing to stop the caller from passing in XML which--- contains an img tag with children. There are three basic ways to--- handle this:------ 1. drop the bogus children silently------ 2. call 'error' \/ raise an exception------ 3. render the img tag with children -- even though it is invalid------ Currently we are taking approach #3, since no other attempts to--- validate the data are made in this function. Instead, you can run--- the output through a full HTML validator to detect the errors.------ #1 seems like a poor choice, since it makes is easy to overlook the--- fact that data went missing.------ We could raising errors, but you have to be in the IO monad to--- catch them. Also, you have to use evaluate if you want to check for--- errors. This means you can not start sending the page until the--- whole page has been rendered. And you have to store the whole page--- in RAM at once. Similar problems occur if we return Either--- instead. We mostly care about catching errors and showing them in--- the browser during testing, so perhaps this can be configurable.------ Another solution would be a compile time error if an empty-only--- tag contained children.------ FIXME: also verify that the domain is correct------ FIXME: what to do if a namespace is encountered--renderAsHTML :: Style -> XML -> Builder-renderAsHTML style xml = renderAsHTML' style 0 xml--data TagType = Open | Close--data Style = Compact | Expanded--renderAsHTML' :: Style -> Int -> XML -> Builder-renderAsHTML' _ _ (CDATA needsEscape cd) = fromString (if needsEscape then (escaper htmlEscapeChars cd) else cd)--renderAsHTML' style n elm@(Element name@(Nothing,nm) attrs children)- | nm == "area" = renderTagEmpty children- | nm == "base" = renderTagEmpty children- | nm == "br" = renderTagEmpty children- | nm == "col" = renderTagEmpty children- | nm == "hr" = renderTagEmpty children- | nm == "img" = renderTagEmpty children- | nm == "input" = renderTagEmpty children- | nm == "link" = renderTagEmpty children- | nm == "meta" = renderTagEmpty children- | nm == "param" = renderTagEmpty children- | nm == "script" = renderElement style n (Element name attrs (map asCDATA children))- | nm == "style" = renderElement style n (Element name attrs (map asCDATA children))- where- renderTagEmpty [] = renderTag style Open n name attrs- renderTagEmpty _ = renderElement style n elm -- this case should not happen in valid HTML- -- for and script\/style, render text in element as CDATA not PCDATA- asCDATA :: XML -> XML- asCDATA (CDATA _ cd) = (CDATA False cd)- asCDATA o = o -- this case should not happen in valid HTML-renderAsHTML' style n e = renderElement style n e--renderElement :: Style -> Int -> XML -> Builder-renderElement style n (Element name attrs children) =- let open = renderTag style Open n name attrs- cs = renderChildren n children- close = renderTag style Close n name []- in mconcat [open, cs, close]- where renderChildren :: Int -> Children -> Builder- renderChildren n' cs = mconcat $ map (renderAsHTML' style (n'+2)) cs-renderElement _ _ _ = error "internal error: renderElement only suports the Element constructor."---renderTag :: Style -> TagType -> Int -> Name -> Attributes -> Builder-renderTag style typ n name attrs =- let (start,end) = case typ of- Open -> (singleton '<' , singleton '>')- Close -> (fromString "</", singleton '>')- nam = showName name- as = renderAttrs attrs- in mconcat [start, nam, as, end]-- where renderAttrs :: Attributes -> Builder- renderAttrs [] = nl- renderAttrs attrs' = mconcat [singleton ' ', ats, nl]- where ats = mconcat $ intersperse (singleton ' ') $ fmap renderAttr attrs'-- renderAttr :: Attribute -> Builder- renderAttr (MkAttr (nam, (Value needsEscape val))) =- mconcat [ showName nam, singleton '=', renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else val)]-- renderAttrVal :: String -> Builder- renderAttrVal s =- mconcat [singleton '\"', fromString s, singleton '\"']-- showName (Nothing, s) = fromString s- showName (Just d, s) = mconcat [fromString d, singleton ':', fromString s]-- nl =- case style of- Compact -> mempty- Expanded -> singleton '\n' `mappend` (fromString $ replicate n ' ')---- This list should be extended.-htmlEscapeChars :: [(Char, String)]-htmlEscapeChars = [- ('&', "amp" ),- ('\"', "quot" ),- ('<', "lt" ),- ('>', "gt" )- ]
Setup.hs view
@@ -3,11 +3,6 @@ module Main where import Distribution.Simple-import Distribution.Simple.Program -trhsxProgram = simpleProgram "trhsx"- main :: IO ()-main = defaultMainWithHooks simpleUserHooks {- hookedPrograms = [trhsxProgram]- }+main = defaultMain
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.16.2+Version: 0.28.0.1 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@@ -16,21 +16,27 @@ License-file: LICENSE Author: Jeremy Shaw Maintainer: Jeremy Shaw <jeremy@n-heptane.com>-Copyright: 2012 SeeReason Partners LLC, Jeremy Shaw+Copyright: 2012-2015 SeeReason Partners LLC, Jeremy Shaw Stability: Experimental Category: Clckwrks-Build-type: Custom-Cabal-version: >=1.6+Build-type: Simple+Cabal-version: 1.18+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2 Data-Files:- static/admin.css+ static/admin.css source-repository head- type: darcs- subdir: clckwrks- location: http://hub.darcs.net/stepcut/clckwrks+ type: git+ location: git://github.com/clckwrks/clckwrks.git +flag network-uri+ description: Get Network.URI from the network-uri package+ default: True+ Library- Build-tools: trhsx+ GHC-Options: -Wunused-top-binds+ Build-tool-depends: hsx2hs:hsx2hs+ default-language: Haskell2010 Exposed-modules: Clckwrks Clckwrks.Acid Clckwrks.Admin.Template@@ -38,13 +44,29 @@ Clckwrks.Admin.Console Clckwrks.Admin.Route Clckwrks.Admin.EditSettings+ Clckwrks.Admin.SystemEmails+ Clckwrks.Authenticate.API+ Clckwrks.Authenticate.Monad+ Clckwrks.Authenticate.Page.AuthModes+ Clckwrks.Authenticate.Page.ChangePassword+ Clckwrks.Authenticate.Page.Login+ Clckwrks.Authenticate.Page.OpenIdRealm+ Clckwrks.Authenticate.Page.ResetPassword+ Clckwrks.Authenticate.Page.ViewUsers+ Clckwrks.Authenticate.Plugin+ Clckwrks.Authenticate.Route+ Clckwrks.Authenticate.URL Clckwrks.BasicTemplate Clckwrks.GetOpts Clckwrks.IOThread+ Clckwrks.JS.ClckwrksApp+ Clckwrks.JS.Route+ Clckwrks.JS.URL Clckwrks.Monad Clckwrks.Server Clckwrks.Markup.HsColour Clckwrks.Markup.Markdown+ Clckwrks.Markup.Pandoc Clckwrks.NavBar.Acid Clckwrks.NavBar.API Clckwrks.NavBar.EditNavBar@@ -56,56 +78,71 @@ Clckwrks.ProfileData.Acid Clckwrks.ProfileData.API Clckwrks.ProfileData.EditProfileData+ Clckwrks.ProfileData.EditNewProfileData Clckwrks.ProfileData.EditProfileDataFor Clckwrks.Route Clckwrks.Types Clckwrks.Unauthorized Clckwrks.URL- HSP.HTMLBuilder Paths_clckwrks+ Extra-Libraries: ssl+-- if !os(darwin)+-- Extra-Libraries: cryptopp + if flag(network-uri)+ build-depends: network > 2.6 && < 3.2,+ network-uri >= 2.6 && < 3.2+ else+ build-depends: network < 2.6+ Build-depends:- acid-state >= 0.7 && < 0.9,- aeson >= 0.5 && < 0.7,- attoparsec == 0.10.*,- base < 5,- blaze-html >= 0.5 && < 0.7,- 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.1.*,- happstack-server >= 7.0 && < 7.2,- happstack-server-tls >= 7.0 && < 7.2,- hsp == 0.7.*,- hsx == 0.10.*,- hsx-jmacro == 7.2.*,- ixset == 1.0.*,+ acid-state >= 0.12 && < 0.17,+ aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.6) || (>= 2 && <= 2.1),+ aeson-qq >= 0.7 && < 0.9,+ attoparsec >= 0.10 && < 0.15,+ base < 5,+ blaze-html >= 0.5 && < 0.10,+ bytestring >= 0.9 && < 0.12,+ cereal >= 0.4 && < 0.6,+ containers >= 0.4 && < 0.7,+ directory >= 1.1 && < 1.4,+ filepath >= 1.2 && < 1.5,+ happstack-authenticate >= 2.6 && < 2.7,+ happstack-hsp == 7.3.*,+ happstack-jmacro >= 7.0 && < 7.1,+ happstack-server >= 7.0 && < 7.8,+ happstack-server-tls >= 7.1 && < 7.3,+ hsp >= 0.9 && < 0.11,+ hsx-jmacro == 7.3.*,+ hsx2hs >= 0.13 && < 0.15,+ http-types < 0.13,+ ixset >= 1.0 && < 1.2, jmacro == 0.6.*,- mtl >= 2.0 && < 2.3,- network >= 2.3 && < 2.5,+ lens >= 4.3 && < 5.2,+ mtl >= 2.0 && < 2.3, old-locale == 1.0.*,- process >= 1.0 && < 1.2,+ process >= 1.0 && < 1.7, -- plugins-auto == 0.0.1.1,- random == 1.0.*,- reform == 0.1.*,- reform-happstack == 0.1.*,- reform-hsp >= 0.1.1 && < 0.2,- safecopy >= 0.6,- stm >= 2.2 && <2.5,- tagsoup == 0.12.*,- text == 0.11.*,- time >= 1.2 && <1.5,- uuid == 1.2.*,- unordered-containers >= 0.1 && < 0.3,- utf8-string == 0.3.*,+ random >= 1.0 && < 1.3,+ reform >= 0.2 && < 0.4,+ reform-happstack == 0.2.*,+ reform-hsp >= 0.2 && < 0.3,+ safecopy >= 0.10,+ stm >= 2.2 && < 2.6,+ text >= 0.11 && < 2.1,+ time >= 1.2 && < 1.14,+ time-locale-compat >= 0.1 && < 0.2,+ uuid-orphans >= 1.2 && < 1.5,+ uuid-types >= 1.0 && < 1.1,+ unordered-containers >= 0.1 && < 0.3,+ userid >= 0.1 && < 0.2,+ utf8-string >= 0.3 && < 1.1, vector >= 0.9,- web-plugins >= 0.1 && < 0.3,+ web-plugins >= 0.4 && < 0.5, web-routes, web-routes-happstack, web-routes-hsp, web-routes-th >= 0.21, xss-sanitize == 0.3.* - -- Build-tools: trhsx+ -- Build-tools: hsx2hs