clckwrks 0.22.4 → 0.28.0.1
raw patch · 43 files changed
Files
- Clckwrks.hs +8/−2
- Clckwrks/Acid.hs +196/−38
- Clckwrks/Admin/EditSettings.hs +58/−11
- Clckwrks/Admin/Route.hs +3/−0
- Clckwrks/Admin/SystemEmails.hs +104/−0
- Clckwrks/Admin/Template.hs +48/−27
- 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/GetOpts.hs +29/−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 +46/−74
- Clckwrks/NavBar/EditNavBar.hs +100/−64
- Clckwrks/NavBar/Types.hs +12/−7
- Clckwrks/Plugin.hs +11/−10
- Clckwrks/ProfileData/API.hs +51/−14
- Clckwrks/ProfileData/Acid.hs +33/−90
- Clckwrks/ProfileData/EditNewProfileData.hs +28/−22
- Clckwrks/ProfileData/EditProfileData.hs +55/−42
- Clckwrks/ProfileData/EditProfileDataFor.hs +125/−38
- Clckwrks/ProfileData/Route.hs +1/−4
- Clckwrks/ProfileData/Types.hs +58/−21
- Clckwrks/ProfileData/URL.hs +4/−4
- Clckwrks/Route.hs +8/−21
- Clckwrks/Server.hs +134/−44
- Clckwrks/Types.hs +2/−2
- Clckwrks/URL.hs +4/−17
- Setup.hs +1/−6
- clckwrks.cabal +65/−39
Clckwrks.hs view
@@ -1,16 +1,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies #-} module Clckwrks ( module Clckwrks.Acid+ , 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 Data.UserId , module Happstack.Server , module Language.Javascript.JMacro , module Web.Routes@@ -18,17 +21,20 @@ ) where import Clckwrks.Acid+import Clckwrks.Authenticate.Plugin (getUserId) import Clckwrks.Admin.URL+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 Language.Javascript.JMacro (JExpr(..), JMacro(..), JStat(..), JType(..), JVal(..), Ident(..), toJExpr, jmacro, jmacroE)
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, 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 (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 ((</>))@@ -39,60 +48,184 @@ -- | '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- { coreSiteName :: Maybe Text- , coreUACCT :: Maybe UACCT -- ^ Google Account UAACT- , coreRootRedirect :: Maybe Text- , coreLoginRedirect :: Maybe Text+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)-$(deriveSafeCopy 1 'extension ''CoreState) +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+ { _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)+ instance Migrate CoreState where- type MigrateFrom CoreState = CoreState_v0- migrate (CoreState_v0 ua rr) = CoreState Nothing ua rr Nothing+ 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- { coreSiteName = Nothing- , coreUACCT = Nothing- , coreRootRedirect = Nothing- , coreLoginRedirect = 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 = coreLoginRedirect <$> ask+getLoginRedirect = view coreLoginRedirect -- | set the path that we should redirect to after login setLoginRedirect :: Maybe Text -> Update CoreState ()-setLoginRedirect path = modify $ \cs -> cs { coreLoginRedirect = path }+setLoginRedirect path = coreLoginRedirect .= path --- | get the site name-getSiteName :: Query CoreState (Maybe Text)-getSiteName = coreSiteName <$> ask+-- | get the From: address for system emails+getFromAddress :: Query CoreState (Maybe SimpleAddress)+getFromAddress = view coreFromAddress --- | set the site name-setSiteName :: Maybe Text -> Update CoreState ()-setSiteName name = modify $ \cs -> cs { coreSiteName = name }+-- | 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@@ -106,20 +239,31 @@ , '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@@ -128,16 +272,30 @@ 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 ->+ -- 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"))+#else bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "profileData_socket") profileData)) (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket"))- (const $ f (Acid auth profile profileData core navBar))+#endif+ (const $ f (Acid profileData core navBar)) where tryRemoveFile fp = removeFile fp `catch` (\e -> if isDoesNotExistError e then return () else throw e) createArchiveCheckpointAndClose acid = do createArchive acid createCheckpointAndClose acid+
Clckwrks/Admin/EditSettings.hs view
@@ -2,9 +2,10 @@ {-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.EditSettings where -import Clckwrks-import Clckwrks.Acid (GetUACCT(..), SetUACCT(..))+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@@ -13,6 +14,7 @@ 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.Text@@ -32,28 +34,65 @@ seeOtherURL here editSettingsForm :: CoreState -> ClckForm ClckURL CoreState-editSettingsForm CoreState{..} =+editSettingsForm c@CoreState{..} = divHorizontal $ fieldset $- (CoreState <$>+ (modifyCoreState <$> (divControlGroup $- (labelText "site name" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>- (divControls (inputText (fromMaybe mempty coreSiteName)) `transformEither` toMaybe)))+ (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))+ (divControls (inputText (unUACCT _coreUACCT)) `transformEither` toMUACCT)) <*> (divControlGroup $ (labelText "/ redirects to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>- (divControls (inputText (fromMaybe mempty coreRootRedirect)) `transformEither` toMaybe))+ (divControls (inputText (fromMaybe mempty _coreRootRedirect)) `transformEither` toMaybe)) <*> (divControlGroup $- (labelText "after login redirect to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>- (divControls (inputText (fromMaybe mempty coreLoginRedirect)) `transformEither` toMaybe))- <*+ (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>])@@ -70,6 +109,14 @@ 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)
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,17 +1,28 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}-{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, QuasiQuotes #-} module Clckwrks.Admin.Template where -import Clckwrks-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 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 HSP.XML (XML, fromStringLit)+import Language.Haskell.HSX.QQ (hsx)+import Web.Plugins.Core (pluginName, getPluginRouteFn) template :: ( Happstack m@@ -20,24 +31,33 @@ ) => String -> headers -> body -> ClckT url m Response template title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName- toResponse <$> (unXMLGenT $+ 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.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 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.2.2/js/bootstrap.min.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>+ <body ng-app="clckwrksApp" ng-controller="AuthenticationCtrl"> <div class="navbar"> <div class="navbar-inner"> <div class="container-fluid">- <a href="/" class="brand">Back to <% siteName %></a>+ <a href=backURL class="brand">Back to <% siteName %></a> </div> </div> </div>@@ -53,7 +73,8 @@ </div> </div> </body>- </html>)+ </html>+ |]) emptyTemplate :: ( Happstack m@@ -62,7 +83,7 @@ ) => String -> headers -> body -> ClckT url m Response emptyTemplate title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName- toResponse <$> (unXMLGenT $+ toResponse <$> (unXMLGenT $ [hsx| <html> <head> <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap.min.css" rel="stylesheet" media="screen" />@@ -95,8 +116,7 @@ </div> </div> </body>- </html>)-+ </html> |]) sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML@@ -105,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 =@@ -122,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/GetOpts.hs view
@@ -31,9 +31,10 @@ , 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-ca"] (ReqArg setTLSCA "path") ("Path to tls .pem file. (required for some certs).")+ , 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))@@ -43,9 +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@@ -54,9 +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 }@@ -87,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, TemplateHaskell #-}+{-# 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@@ -26,7 +26,6 @@ , mapClckT , withRouteClckT , ClckState(..)- , getUserId , Content(..) -- , markupToContent -- , addPreProcessor@@ -41,14 +40,12 @@ , googleAnalytics , getUnique , setUnique- , requiresRole- , requiresRole_ , setRedirectCookie , getRedirectCookie- , getUserRoles , query , update , nestURL+ , isSecure , withAbs , withAbs' , segments@@ -60,7 +57,7 @@ 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(..))@@ -68,6 +65,9 @@ import Clckwrks.Unauthorized (unauthorizedPage) import Clckwrks.URL (ClckURL(..)) 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)@@ -100,14 +100,12 @@ 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 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+ , toResponse, getHeaderUnsafe ) import Happstack.Server.HSP.HTML () -- ToMessage XML instance import Happstack.Server.XMLGenT () -- instance Happstack XMLGenT@@ -120,7 +118,7 @@ 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.Text (renderHtml) import Text.Reform (CommonFormError, Form, FormError(..))@@ -148,7 +146,8 @@ { themeStyleName :: T.Text , themeStyleDescription :: T.Text , themeStylePreview :: Maybe FilePath- , themeStyleTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers+ , themeStyleTemplate :: forall headers body.+ ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) => T.Text -> headers@@ -204,9 +203,10 @@ data TLSSettings = TLSSettings { clckTLSPort :: Int- , clckTLSCert :: FilePath- , clckTLSKey :: FilePath+ , clckTLSCert :: Maybe FilePath+ , clckTLSKey :: Maybe FilePath , clckTLSCA :: Maybe FilePath+ , clckTLSRev :: Bool } data ClckwrksConfig = ClckwrksConfig@@ -254,7 +254,11 @@ ------------------------------------------------------------------------------ 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) @@ -304,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@@ -323,17 +327,18 @@ ------------------------------------------------------------------------------ data ClckPluginsSt = ClckPluginsSt- { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO TL.Text]- , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]+ { 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 :: ClckPluginsSt-initialClckPluginsSt = ClckPluginsSt+initialClckPluginsSt :: Acid -> ClckPluginsSt+initialClckPluginsSt acid = ClckPluginsSt { cpsPreProcessors = []- , cpsNavBarLinks = []+ , cpsNavBarLinks = []+ , cpsAcid = acid } - -- | ClckPlugins -- -- newtype Plugins theme m hook config st@@ -383,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 @@ -423,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 @@ -438,13 +447,6 @@ 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@@ -604,7 +606,7 @@ 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) }@@ -671,35 +673,6 @@ do expireCookie "clckwrks-authenticate-redirect" optional $ lookCookieValue "clckwrks-authenticate-redirect" -requiresRole_ :: (Happstack m) => (ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text) -> Set Role -> url -> ClckT u m url-requiresRole_ showFn role url =- ClckT $ RouteT $ \_ -> unRouteT (unClckT (requiresRole role url)) showFn--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)- 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) ->- do mr <- query (GetRoles u)- case mr of- Nothing -> return Set.empty- (Just r) -> return r- ------------------------------------------------------------------------------ -- NavBar callback ------------------------------------------------------------------------------@@ -721,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 --
@@ -13,12 +13,13 @@ import Control.Monad.State (get) import Control.Monad.Trans (lift, liftIO) import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=), decode, object)+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.XML (fromStringLit)+import HSP.XML (XML, fromStringLit) import HSP.XMLGenerator import Language.Javascript.JMacro import Web.Routes (showURL)@@ -52,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>@@ -72,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)`;+ }); |] %> </%>@@ -130,6 +134,7 @@ option.text(navBarLinks[p].pluginName); pluginList.append(option); }+ populateLinks(0); pluginList.change(function() { populateLinks($(this).val()); }); @@ -137,16 +142,19 @@ $("#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); }); |]@@ -155,7 +163,7 @@ 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 });@@ -174,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@@ -197,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 ]@@ -220,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"@@ -241,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,11 +63,15 @@ 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, Bool)@@ -105,35 +82,18 @@ return (pd, True) (Just pd') -> return (pd', False) -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)- 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
@@ -3,20 +3,27 @@ module Clckwrks.ProfileData.EditNewProfileData where import Clckwrks-import Clckwrks.Monad (getRedirectCookie)-import Clckwrks.Admin.Template (emptyTemplate)-import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)+import Clckwrks.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 Data.Text (pack)-import qualified Data.Text as Text-import Data.Text.Lazy (Text)-import Data.Maybe (fromMaybe)-import Happstack.Auth (UserId)-import Text.Reform ((++>), mapView, transformEitherM)-import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs)-import Text.Reform.Happstack (reform)+import 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. @@ -26,17 +33,16 @@ case mUid of Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) (Just uid) ->- do mpd <- query (GetProfileData uid)- case mpd of- Nothing ->- internalServerError $ toResponse $ "Missing profile data for " ++ show uid-- (Just pd) ->- do action <- showURL here- emptyTemplate "Edit Profile Data" () $- <%>- <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>- </%>+ 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 () =
Clckwrks/ProfileData/EditProfileData.hs view
@@ -1,20 +1,28 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}-{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+{-# 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 (pack)-import qualified Data.Text as Text-import Data.Text.Lazy (Text)-import Data.Maybe (fromMaybe)-import Happstack.Auth (UserId)-import Text.Reform ((++>), mapView, transformEitherM)-import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs)-import Text.Reform.Happstack (reform)+import 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. @@ -24,42 +32,47 @@ case mUid of Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) (Just uid) ->- do mpd <- query (GetProfileData uid)- case mpd of- Nothing ->- internalServerError $ toResponse $ "Missing profile data for " ++ show uid-- (Just pd) ->- do action <- showURL here- 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") :: Attr Text Text)))))+ ((,) <$> (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 = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])- 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, 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,59 +1,146 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}-{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+{-# 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 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 Text.Reform ((++>), transformEitherM)+import System.FilePath ((</>))+import Text.Reform ((++>), mapView, transformEitherM) import Text.Reform.Happstack (reform)-import Text.Reform.HSP.Text (inputCheckboxes, inputText, labelText, 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 $ labelText "username:") ++> (li $ inputText username)- <*> (li $ labelText "email (optional):") ++> (li $ inputText (fromMaybe Text.empty email))- <*> (li $ labelText "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
@@ -20,10 +20,7 @@ case mUserId of Nothing -> internalServerError $ toResponse $ "not logged in." (Just userId) ->- do let profileData = emptyProfileData { dataFor = userId- , roles = singleton Visitor- }- (_, new) <- update (NewProfileData profileData)+ do (_, new) <- update (NewProfileData (defaultProfileDataFor userId)) if new then seeOtherURL EditNewProfileData else do mRedirect <- query GetLoginRedirect
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,10 +1,10 @@ {-# 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
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)@@ -28,7 +30,7 @@ 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@@ -77,21 +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) (ThemeStyleId 0) (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,71 +3,93 @@ 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, fromMaybe)+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 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- , requestInit = return ()- }- 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- , tlsCA = clckTLSCA- }- 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@@ -76,11 +98,14 @@ where handlers :: ClckwrksConfig -> ClckState -> ServerPart Response handlers cc clckState =- do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6))+ 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 [] , do nullDir mRR <- query' (acidCore . acidState $ clckState) GetRootRedirect@@ -88,6 +113,26 @@ , 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)@@ -98,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
@@ -12,13 +12,13 @@ import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy, safeGet, safePut, contain) import Data.Text (Text) import qualified Data.Text.Encoding as T-import Data.UUID (UUID)+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 }
Clckwrks/URL.hs view
@@ -2,23 +2,18 @@ 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 ((<$>), many) import Data.Data (Data, Typeable) import Data.SafeCopy (Migrate(..), SafeCopy(..), base, deriveSafeCopy, extension) import Data.Text (Text, pack, unpack)-import Happstack.Auth (AuthURL(..), ProfileURL(..), AuthProfileURL(..), UserId)-import Happstack.Auth.Core.AuthURL (OpenIdURL, AuthMode, OpenIdProvider)+import Happstack.Authenticate.Core (AuthenticateURL(..)) import System.FilePath (joinPath, splitDirectories) import Web.Routes (PathInfo(..), anySegment) import Web.Routes.TH (derivePathInfo)@@ -38,15 +33,7 @@ | PluginData Text FilePath | Admin AdminURL | Profile ProfileDataURL- | Auth AuthProfileURL+ | JS JSURL deriving (Eq, Ord, Data, Typeable, Read, Show)---- 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)
Setup.hs view
@@ -3,11 +3,6 @@ module Main where import Distribution.Simple-import Distribution.Simple.Program -hsx2hsProgram = simpleProgram "hsx2hs"- main :: IO ()-main = defaultMainWithHooks simpleUserHooks {- hookedPrograms = [hsx2hsProgram]- }+main = defaultMain
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.22.4+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,13 +16,14 @@ 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: git@@ -33,7 +34,9 @@ default: True Library- Build-tools: hsx2hs+ GHC-Options: -Wunused-top-binds+ Build-tool-depends: hsx2hs:hsx2hs+ default-language: Haskell2010 Exposed-modules: Clckwrks Clckwrks.Acid Clckwrks.Admin.Template@@ -41,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@@ -67,52 +86,59 @@ Clckwrks.URL Paths_clckwrks Extra-Libraries: ssl- if !os(darwin)- Extra-Libraries: cryptopp+-- if !os(darwin)+-- Extra-Libraries: cryptopp if flag(network-uri)- build-depends: network > 2.6 && < 2.7,- network-uri >= 2.6 && < 2.7+ build-depends: network > 2.6 && < 3.2,+ network-uri >= 2.6 && < 3.2 else build-depends: network < 2.6 Build-depends:- acid-state >= 0.12 && < 0.13,- aeson >= 0.5 && < 0.9,- attoparsec >= 0.10 && < 0.13,- base < 5,- blaze-html >= 0.5 && < 0.8,- bytestring >= 0.9 && < 0.11,- cereal >= 0.4 && < 0.5,- containers >= 0.4 && < 0.6,- directory >= 1.1 && < 1.3,- filepath >= 1.2 && < 1.4,- happstack-authenticate == 0.10.*,+ 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-server >= 7.0 && < 7.4,- happstack-server-tls >= 7.1 && < 7.2,- hsp >= 0.9 && < 0.11,+ 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.*,- ixset == 1.0.*,+ hsx2hs >= 0.13 && < 0.15,+ http-types < 0.13,+ ixset >= 1.0 && < 1.2, jmacro == 0.6.*,- mtl >= 2.0 && < 2.3,+ lens >= 4.3 && < 5.2,+ mtl >= 2.0 && < 2.3, old-locale == 1.0.*,- process >= 1.0 && < 1.3,+ process >= 1.0 && < 1.7, -- plugins-auto == 0.0.1.1,- random == 1.0.*,- reform == 0.2.*,+ random >= 1.0 && < 1.3,+ reform >= 0.2 && < 0.4, reform-happstack == 0.2.*,- reform-hsp >= 0.2 && < 0.3,- safecopy >= 0.6,- stm >= 2.2 && <2.5,- tagsoup >= 0.12 && < 0.14,- text >= 0.11 && < 1.2,- time >= 1.2 && <1.5,- uuid >= 1.2 && < 1.4,- unordered-containers >= 0.1 && < 0.3,- utf8-string == 0.3.*,+ 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,