clckwrks 0.23.19.2 → 0.28.0.1
raw patch · 33 files changed
Files
- Clckwrks/Acid.hs +190/−29
- Clckwrks/Admin/EditSettings.hs +58/−11
- Clckwrks/Admin/Route.hs +3/−0
- Clckwrks/Admin/SystemEmails.hs +104/−0
- Clckwrks/Admin/Template.hs +5/−4
- 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 +5/−2
- Clckwrks/Authenticate/Page/Login.hs +1/−1
- Clckwrks/Authenticate/Page/ResetPassword.hs +3/−1
- Clckwrks/Authenticate/Page/ViewUsers.hs +37/−0
- Clckwrks/Authenticate/Plugin.hs +42/−31
- Clckwrks/Authenticate/Route.hs +41/−14
- Clckwrks/Authenticate/URL.hs +2/−0
- Clckwrks/GetOpts.hs +28/−17
- Clckwrks/JS/ClckwrksApp.hs +23/−2
- Clckwrks/JS/Route.hs +3/−3
- Clckwrks/Markup/Markdown.hs +1/−0
- Clckwrks/Monad.hs +38/−19
- Clckwrks/NavBar/Types.hs +12/−7
- Clckwrks/Plugin.hs +11/−10
- Clckwrks/ProfileData/API.hs +6/−4
- Clckwrks/ProfileData/Acid.hs +5/−63
- Clckwrks/ProfileData/EditNewProfileData.hs +14/−3
- Clckwrks/ProfileData/EditProfileData.hs +44/−28
- Clckwrks/ProfileData/EditProfileDataFor.hs +126/−33
- Clckwrks/ProfileData/Types.hs +50/−20
- Clckwrks/Route.hs +4/−2
- Clckwrks/Server.hs +88/−27
- Setup.hs +1/−6
- clckwrks.cabal +35/−28
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.Authenticate.Core (AuthenticateState)+import qualified Data.Text as Text+import Happstack.Authenticate.Core (AuthenticateState, SimpleAddress(..)) import Happstack.Authenticate.Password.Core (PasswordState)-import Network (PortID(UnixSocket)) 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,10 +239,22 @@ , 'setUACCT , 'getRootRedirect , 'setRootRedirect+ , 'getBackToSiteRedirect+ , 'setBackToSiteRedirect , 'getLoginRedirect , 'setLoginRedirect+ , 'getBodyPolicy+ , 'setBodyPolicy , 'getSiteName , 'setSiteName+ , 'getFromAddress+ , 'setFromAddress+ , 'getReplyToAddress+ , 'setReplyToAddress+ , 'getSendmailPath+ , 'setSendmailPath+ , 'setEnableOpenId+ , 'getEnableOpenId , 'getCoreState , 'setCoreState ])@@ -127,14 +272,30 @@ withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a withAcid mBasePath f = let basePath = fromMaybe "_state" mBasePath in- 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"))+#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
@@ -3,7 +3,7 @@ import Control.Applicative ((<$>)) import Control.Monad.Trans (lift)-import Clckwrks.Acid (GetSiteName(..))+import Clckwrks.Acid (GetSiteName(..), GetBackToSiteRedirect(..)) import Clckwrks.Monad (ClckT(..), ClckState(adminMenus), plugins, query) import Clckwrks.URL (ClckURL(JS)) import Clckwrks.JS.URL (JSURL(..))@@ -31,9 +31,10 @@ ) => String -> headers -> body -> ClckT url m Response template title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName+ backURL <- query GetBackToSiteRedirect p <- plugins <$> get- (Just authShowURL) <- getPluginRouteFn p (pluginName authenticatePlugin)- (Just clckShowURL) <- getPluginRouteFn p "clck"+ ~(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>@@ -56,7 +57,7 @@ <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>
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
@@ -9,8 +9,11 @@ changePasswordPanel :: ClckT ClckURL (ServerPartT IO) Response changePasswordPanel =- do template "Upload Medium" () $ [hsx|+ do template "Change Password" () $ [hsx| <%>- <up-change-password />+ <h2>Change Password</h2>+ <div ng-controller="UsernamePasswordCtrl">+ <up-change-password />+ </div> </%> |]
Clckwrks/Authenticate/Page/Login.hs view
@@ -3,8 +3,8 @@ import Control.Applicative ((<$>)) import Clckwrks.Monad (ClckT, ThemeStyleId(..), plugins, themeTemplate)-import Clckwrks.URL (ClckURL(..)) import Clckwrks.Authenticate.URL+import Clckwrks.URL (ClckURL) import Control.Monad.State (get) import Happstack.Server (Response, ServerPartT) import HSP
Clckwrks/Authenticate/Page/ResetPassword.hs view
@@ -16,5 +16,7 @@ themeTemplate plugins (ThemeStyleId 0) "Reset Password" () [hsx| <%> <h2>Reset Password</h2>- <up-reset-password />+ <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
@@ -1,8 +1,11 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings #-}+{-# 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 (acidProfileData)+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(..))@@ -11,9 +14,10 @@ import Clckwrks.URL import Control.Applicative ((<$>)) import Control.Lens ((^.))+import Control.Monad.Reader (ask) import Control.Monad.State (get)-import Control.Monad.Trans (lift)-import Data.Acid as Acid (AcidState, query)+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@@ -25,17 +29,14 @@ 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(..))-import Happstack.Authenticate.Password.Route (initPassword)+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 ((</>))-import Web.Plugins.Core (Plugin(..), addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin)+import System.FilePath ((</>), combine)+import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin) import Web.Routes -newtype AcidStateAuthenticate = AcidStateAuthenticate { acidStateAuthenticate :: AcidState AuthenticateState }- deriving Typeable- authenticateHandler :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response) -> (AuthURL -> [(Text, Maybe Text)] -> Text)@@ -45,7 +46,7 @@ authenticateHandler routeAuthenticate showAuthenticateURL _plugins paths = case parseSegments fromPathSegments paths of (Left e) -> notFound $ toResponse (show e)- (Right u) -> routeAuth routeAuthenticate u -- ClckT $ withRouteT flattenURL $ unClckT $+ (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@@ -58,15 +59,17 @@ 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 [])])+ ~(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)+ do ~(Just authShowFn) <- getPluginRouteFn plugins (pluginName authenticatePlugin) addNavBarCallback plugins (authMenuCallback authShowFn) -- addHandler plugins (pluginName clckPlugin) (authenticateHandler clckShowFn) cc <- getConfig plugins@@ -75,10 +78,16 @@ 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+ _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 [] <> "/#"@@ -86,12 +95,13 @@ , _passwordAcceptable = const Nothing } - (authCleanup, routeAuthenticate, authenticateState) <- initAuthentication (Just basePath) authenticateConfig- [ initPassword passwordConfig- , initOpenId- ]+ 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) (AcidStateAuthenticate authenticateState)+ addPluginState plugins (pluginName authenticatePlugin) (AuthenticatePluginState authenticateState passwordState authenticateConfigTV passwordConfigTV)+ addCleanup plugins Always authCleanup return Nothing {- addClckAdminMenu :: ClckT url IO ()@@ -112,11 +122,11 @@ -} authenticatePlugin :: Plugin AuthURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt authenticatePlugin = Plugin- { pluginName = "authenticate"- , pluginInit = authenticateInit- , pluginDepends = []- , pluginToPathInfo = toPathInfo- , pluginPostHook = addAuthAdminMenu+ { pluginName = "authenticate"+ , pluginInit = authenticateInit+ , pluginDepends = []+ , pluginToPathSegments = toPathSegments+ , pluginPostHook = addAuthAdminMenu } plugin :: ClckPlugins@@ -128,8 +138,9 @@ getUserId :: (Happstack m) => ClckT url m (Maybe UserId) getUserId = do p <- plugins <$> get- (Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)- mToken <- getToken authenticateState+ ~(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/Route.hs view
@@ -2,32 +2,59 @@ module Clckwrks.Authenticate.Route where import Control.Applicative ((<$>))-import Clckwrks.Monad (ClckT, plugins)+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 (Response, ServerPartT)-import Web.Routes (RouteT, askRouteFn, runRouteT)+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 ClckURL (ServerPartT IO) Response-routeAuth routeAuthenticate u =- case u of- (Auth authenticateURL) ->- do p <- plugins <$> get- (Just authShowFn) <- getPluginRouteFn p "authenticate"- lift $ runRouteT routeAuthenticate (authShowFn . Auth) authenticateURL- Login -> loginPage- ResetPassword -> resetPasswordPage- ChangePassword -> changePasswordPanel- OpenIdRealm -> openIdRealmPanel+ -> 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
@@ -15,6 +15,8 @@ | ResetPassword | ChangePassword | OpenIdRealm+ | AuthModes+ | ViewUsers deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) derivePathInfo ''AuthURL
Clckwrks/GetOpts.hs view
@@ -31,7 +31,8 @@ , 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 hostname, default: " ++ show (clckHostname def)) , Option [] ["jquery-path"] (ReqArg setJQueryPath "path") ("path to jquery directory, default: " ++ show (clckJQueryPath 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
@@ -3,13 +3,34 @@ import Language.Javascript.JMacro -clckwrksAppJS :: JStat-clckwrksAppJS = [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' ]);
Clckwrks/JS/Route.hs view
@@ -7,7 +7,7 @@ import Happstack.Server (Happstack, Response, ok, toResponse) import Happstack.Server.JMacro () -routeJS :: (Happstack m) => JSURL -> ClckT u m Response-routeJS url =+routeJS :: (Happstack m) => Bool -> JSURL -> ClckT u m Response+routeJS enableOpenId url = case url of- ClckwrksApp -> ok $ toResponse $ clckwrksAppJS+ ClckwrksApp -> ok $ toResponse $ clckwrksAppJS enableOpenId
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/Monad.hs view
@@ -1,4 +1,4 @@-{-# 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@@ -45,6 +45,7 @@ , query , update , nestURL+ , isSecure , withAbs , withAbs' , segments@@ -56,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(..))@@ -64,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)@@ -101,7 +105,7 @@ , 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@@ -199,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@@ -249,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) @@ -299,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@@ -318,9 +327,9 @@ ------------------------------------------------------------------------------ data ClckPluginsSt = ClckPluginsSt- { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO 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+ { cpsPreProcessors :: forall m. (Functor m, MonadIO m, Happstack m) => [TL.Text -> ClckT ClckURL m TL.Text]+ , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]+ , cpsAcid :: Acid -- ^ this value is also in ClckState, but it is sometimes needed by plugins during initPlugin } initialClckPluginsSt :: Acid -> ClckPluginsSt@@ -382,11 +391,24 @@ 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 @@ -415,10 +437,7 @@ instance (GetAcidState m st) => GetAcidState (XMLGenT m) st where getAcidState = XMLGenT getAcidState-{--instance (Functor m, Monad m) => GetAcidState (ClckT url m) AuthenticateState where- getAcidState = (acidAuthenticate . acidState) <$> get--}+ instance (Functor m, Monad m) => GetAcidState (ClckT url m) CoreState where getAcidState = (acidCore . acidState) <$> get @@ -587,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) }@@ -675,10 +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 --
@@ -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,11 +1,12 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Clckwrks.ProfileData.API- ( getProfileData- , getUsername+ ( getDisplayName+ , getProfileData , getUserRoles , requiresRole , requiresRole_ , whoami+ , Role(..) ) where import Clckwrks.Acid (Acid(..))@@ -23,14 +24,15 @@ 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 ProfileData getProfileData uid = query (GetProfileData uid) -getUsername :: UserId -> Clck url Text-getUsername uid = query (GetUsername uid)+getDisplayName :: UserId -> Clck url (Maybe DisplayName)+getDisplayName uid = displayName <$> query (GetProfileData uid) whoami :: Clck url (Maybe UserId) whoami = getUserId
Clckwrks/ProfileData/Acid.hs view
@@ -2,21 +2,17 @@ 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(..), defaultProfileDataFor)+import Clckwrks.ProfileData.Types (ProfileData(..), Role(..), defaultProfileDataFor) import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.State (get, put)@@ -40,37 +36,11 @@ 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)) &&- ((dataFor existingPd) /= (dataFor 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@@ -112,17 +82,6 @@ return (pd, True) (Just pd') -> return (pd', False) -getUsername :: UserId- -> Query ProfileDataState Text-getUsername uid =- 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 (Set Role) getRoles uid =@@ -152,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
@@ -5,18 +5,25 @@ import Clckwrks import Clckwrks.Monad (getRedirectCookie) import Clckwrks.Admin.Template (emptyTemplate)-import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)+import Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..))+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..)) import Clckwrks.ProfileData.EditProfileData(profileDataFormlet)+import Control.Monad.State (get)+import Control.Monad.Trans (liftIO)+import qualified Data.Acid as Acid import Data.Text (pack) import qualified Data.Text as Text import Data.Text.Lazy (Text) import Data.Maybe (fromMaybe) import Data.UserId (UserId)+import Happstack.Authenticate.Core (Email(..), User(..), GetUserByUserId(..), UpdateUser(..)) import Text.Reform ((++>), mapView, transformEitherM) import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs) import Text.Reform.Happstack (reform) import HSP.XMLGenerator import HSP.XML+import Web.Plugins.Core (Plugin(..), getPluginState) -- FIXME: this currently uses the admin template. Which is sort of right, and sort of not. @@ -26,11 +33,15 @@ case mUid of Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) (Just uid) ->- do pd <- query (GetProfileData uid)+ do -- pd <- query (GetProfileData uid)+ p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ ~(Just user) <- liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid)+ pd <- query (GetProfileData uid) action <- showURL here emptyTemplate "Edit Profile Data" () $ <%>- <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>+ <% reform (form action) "epd" updated Nothing (profileDataFormlet user pd) %> </%> where updated :: () -> Clck ProfileDataURL Response
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.Monad (plugins) import Clckwrks.Admin.Template (template)-import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)+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,39 +32,47 @@ case mUid of Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) (Just uid) ->- do pd <- query (GetProfileData uid)+ do -- pd <- query (GetProfileData uid)+ p <- plugins <$> get+ ~(Just aps) <- getPluginState p (pluginName authenticatePlugin)+ ~(Just user) <- liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid)+ pd <- query (GetProfileData uid) action <- showURL here- template "Edit Profile Data" () $+ template "Edit Profile Data" () $ [hsx| <%>- <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>- <up-change-password />- </%>+ <% 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' :: Text -> ClckForm ProfileDataURL ()- 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,53 +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 Data.UserId (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 pd <- query (GetProfileData uid)- action <- showURL here- template "Edit Profile Data" () $- <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>-+ mu <- query (GetUserByUserId uid)+ case mu of+ Nothing ->+ 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/Types.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeFamilies #-} module Clckwrks.ProfileData.Types- ( ProfileData(..)+ ( DisplayName(..)+ , ProfileData(..) , Role(..) , defaultProfileDataFor , emptyProfileData@@ -16,11 +17,12 @@ 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@@ -28,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@@ -36,25 +38,57 @@ 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 -- ^ now comes from happstack-authenticate- , email :: Maybe Text -- ^ now comes from happstack-authenticate- , 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 } defaultProfileDataFor :: UserId -> ProfileData@@ -63,12 +97,8 @@ , roles = singleton Visitor } -newtype Username = Username { unUsername :: Text }- deriving (Eq, Ord, Read, Show, Data, Typeable)- instance Indexable ProfileData where empty = ixSet [ ixFunS dataFor- , ixFunS $ Username . username ] where ixFunS :: (Ord b, Typeable b) => (a -> b) -> Ix a
Clckwrks/Route.hs view
@@ -2,9 +2,10 @@ 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)@@ -79,4 +80,5 @@ do nestURL Profile $ routeProfileData profileDataURL (JS jsURL) ->- do nestURL JS $ routeJS jsURL+ do b <- query GetEnableOpenId+ nestURL JS $ routeJS b jsURL
Clckwrks/Server.hs view
@@ -7,28 +7,38 @@ -- 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, 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 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@@ -57,7 +67,7 @@ (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 @@ -65,14 +75,18 @@ 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@@ -85,11 +99,13 @@ handlers :: ClckwrksConfig -> ClckState -> ServerPart Response handlers cc clckState = do forceCanonicalHost- decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6))+ 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@@ -105,7 +121,7 @@ (Just hostBS) -> if (clckHostname cc == (B.unpack $ B.takeWhile (/= ':') hostBS)) then return ()- else escape $ seeOther ((if rqSecure rq then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ())+ 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@@ -127,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
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.23.19.2+Version: 0.28.0.1 Synopsis: A secure, reliable content management system (CMS) and blogging platform Description: clckwrks (pronounced, clockworks) aims to compete directly with popular PHP-based blogging and CMS@@ -19,11 +19,11 @@ Copyright: 2012-2015 SeeReason Partners LLC, Jeremy Shaw Stability: Experimental Category: Clckwrks-Build-type: Custom-Cabal-version: >=1.16-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+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@@ -34,7 +34,8 @@ default: True Library- Build-tools: hsx2hs+ GHC-Options: -Wunused-top-binds+ Build-tool-depends: hsx2hs:hsx2hs default-language: Haskell2010 Exposed-modules: Clckwrks Clckwrks.Acid@@ -43,10 +44,15 @@ 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@@ -84,46 +90,47 @@ -- 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.15,- aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.1),+ 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.14,+ attoparsec >= 0.10 && < 0.15, base < 5,- blaze-html >= 0.5 && < 0.9,- bytestring >= 0.9 && < 0.11,+ blaze-html >= 0.5 && < 0.10,+ bytestring >= 0.9 && < 0.12, cereal >= 0.4 && < 0.6,- containers >= 0.4 && < 0.6,- directory >= 1.1 && < 1.3,+ containers >= 0.4 && < 0.7,+ directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5,- happstack-authenticate >= 2.3 && < 2.4,+ happstack-authenticate >= 2.6 && < 2.7, happstack-hsp == 7.3.*, happstack-jmacro >= 7.0 && < 7.1,- happstack-server >= 7.0 && < 7.5,- happstack-server-tls >= 7.1 && < 7.2,+ happstack-server >= 7.0 && < 7.8,+ happstack-server-tls >= 7.1 && < 7.3, hsp >= 0.9 && < 0.11, hsx-jmacro == 7.3.*, hsx2hs >= 0.13 && < 0.15,- ixset == 1.0.*,+ http-types < 0.13,+ ixset >= 1.0 && < 1.2, jmacro == 0.6.*,- lens >= 4.3 && < 4.16,+ lens >= 4.3 && < 5.2, mtl >= 2.0 && < 2.3, old-locale == 1.0.*,- process >= 1.0 && < 1.5,+ process >= 1.0 && < 1.7, -- plugins-auto == 0.0.1.1,- random >= 1.0 && < 1.2,- 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,- text >= 0.11 && < 1.3,- time >= 1.2 && < 1.7,+ 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,@@ -131,7 +138,7 @@ 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,