clckwrks 0.24.0.15 → 0.25.0
raw patch · 24 files changed
+492/−199 lines, 24 filesdep ~happstack-authenticate
Dependency ranges changed: happstack-authenticate
Files
- Clckwrks/Acid.hs +99/−27
- Clckwrks/Admin/EditSettings.hs +14/−7
- Clckwrks/Admin/Route.hs +2/−0
- Clckwrks/Admin/SystemEmails.hs +104/−0
- Clckwrks/Admin/URL.hs +2/−1
- Clckwrks/Authenticate/API.hs +36/−0
- Clckwrks/Authenticate/Page/AuthModes.hs +56/−0
- Clckwrks/Authenticate/Page/Login.hs +1/−1
- Clckwrks/Authenticate/Plugin.hs +20/−10
- Clckwrks/Authenticate/Route.hs +38/−14
- Clckwrks/Authenticate/URL.hs +1/−0
- Clckwrks/JS/ClckwrksApp.hs +23/−2
- Clckwrks/JS/Route.hs +3/−3
- Clckwrks/Monad.hs +2/−6
- Clckwrks/Plugin.hs +4/−3
- Clckwrks/ProfileData/API.hs +2/−4
- Clckwrks/ProfileData/Acid.hs +3/−63
- Clckwrks/ProfileData/EditNewProfileData.hs +13/−4
- Clckwrks/ProfileData/EditProfileData.hs +35/−27
- Clckwrks/ProfileData/EditProfileDataFor.hs +8/−16
- Clckwrks/ProfileData/Types.hs +17/−6
- Clckwrks/Route.hs +4/−2
- Clckwrks/Server.hs +0/−1
- clckwrks.cabal +5/−2
Clckwrks/Acid.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE 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)@@ -17,7 +19,7 @@ import Data.Maybe (fromMaybe) import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.Text (Text)-import Happstack.Authenticate.Core (AuthenticateState)+import Happstack.Authenticate.Core (AuthenticateState, SimpleAddress(..)) import Happstack.Authenticate.Password.Core (PasswordState) import Network (PortID(UnixSocket)) import Prelude hiding (catch)@@ -39,60 +41,117 @@ -- | '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)+$(deriveSafeCopy 1 'extension ''CoreState_1) +instance Migrate CoreState_1 where+ type MigrateFrom CoreState_1 = CoreState_v0+ migrate (CoreState_v0 ua rr) = CoreState_1 Nothing ua rr Nothing++-- | '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+ , _coreFromAddress :: Maybe SimpleAddress+ , _coreReplyToAddress :: Maybe SimpleAddress+ , _coreSendmailPath :: Maybe FilePath+ , _coreEnableOpenId :: Bool -- ^ allow OpenId authentication+ }+ deriving (Eq, Data, Typeable, Show)+$(deriveSafeCopy 2 'extension ''CoreState)++makeLenses ''CoreState instance Migrate CoreState where- type MigrateFrom CoreState = CoreState_v0- migrate (CoreState_v0 ua rr) = CoreState Nothing ua rr Nothing+ type MigrateFrom CoreState = CoreState_1+ migrate (CoreState_1 sn ua rr lr) = CoreState sn ua rr lr Nothing Nothing Nothing True initialCoreState :: CoreState initialCoreState = CoreState- { coreSiteName = Nothing- , coreUACCT = Nothing- , coreRootRedirect = Nothing- , coreLoginRedirect = Nothing+ { _coreSiteName = Nothing+ , _coreUACCT = Nothing+ , _coreRootRedirect = Nothing+ , _coreLoginRedirect = Nothing+ , _coreFromAddress = Nothing+ , _coreReplyToAddress = Nothing+ , _coreSendmailPath = Nothing+ , _coreEnableOpenId = True } +-- | 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 -- | 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 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@@ -110,6 +169,14 @@ , 'setLoginRedirect , 'getSiteName , 'setSiteName+ , 'getFromAddress+ , 'setFromAddress+ , 'getReplyToAddress+ , 'setReplyToAddress+ , 'getSendmailPath+ , 'setSendmailPath+ , 'setEnableOpenId+ , 'getEnableOpenId , 'getCoreState , 'setCoreState ])@@ -127,9 +194,13 @@ 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+ bracket (forkIO (tryRemoveFile (basePath </> "core_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "core_socket") profileData))+ (\tid -> killThread tid >> tryRemoveFile (basePath </> "core_socket")) $ const $ bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "profileData_socket") profileData)) (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket")) (const $ f (Acid profileData core navBar))@@ -138,3 +209,4 @@ createArchiveCheckpointAndClose acid = do createArchive acid createCheckpointAndClose acid+
Clckwrks/Admin/EditSettings.hs view
@@ -3,8 +3,9 @@ module Clckwrks.Admin.EditSettings where import Clckwrks-import Clckwrks.Acid (GetUACCT(..), SetUACCT(..))+import Clckwrks.Acid (GetUACCT(..), SetUACCT(..), coreSiteName, coreUACCT, coreRootRedirect, coreLoginRedirect) import Clckwrks.Admin.Template (template)+import Control.Lens ((&), (.~)) import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack) import qualified Data.Text as T@@ -32,25 +33,25 @@ 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)))+ (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))+ (divControls (inputText (fromMaybe mempty _coreLoginRedirect)) `transformEither` toMaybe)) <* (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text]) where@@ -70,6 +71,12 @@ if T.null txt then Right $ Nothing else Right $ Just txt++ modifyCoreState sn ua rr lr =+ c & coreSiteName .~ sn+ & coreUACCT .~ ua+ & coreRootRedirect .~ rr+ & coreLoginRedirect .~ lr {- 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,4 @@ 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/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,36 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+module Clckwrks.Authenticate.API+ ( Username(..)+ , getEmail+ , getUser+ , getUsername+ ) where++import Clckwrks.Monad (Clck, plugins)+import Control.Monad (join)+import Control.Monad.State (get)+import Control.Monad.Trans (liftIO)+import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin)+import Data.Acid as Acid (AcidState, query)+import Data.Maybe (maybe)+import Data.Monoid (mempty)+import Data.Text (Text)+import Data.UserId (UserId)+import Happstack.Authenticate.Core (GetUserByUserId(..), Email(..), User(..), Username(..))+import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin)++getUser :: UserId -> Clck url (Maybe User)+getUser uid =+ do p <- plugins <$> get+ ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+ liftIO $ Acid.query authenticateState (GetUserByUserId uid)++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
+ 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/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/Plugin.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings, MultiParamTypeClasses #-} module Clckwrks.Authenticate.Plugin where import Clckwrks.Monad-import Clckwrks.Acid (acidProfileData)+import Clckwrks.Acid (GetAcidState(..), GetCoreState(..), GetEnableOpenId(..), acidCore, acidProfileData, coreFromAddress, coreReplyToAddress, coreSendmailPath, getAcidState) import Clckwrks.Authenticate.Route (routeAuth) import Clckwrks.Authenticate.URL (AuthURL(..)) import Clckwrks.ProfileData.Acid (HasRole(..))@@ -11,8 +11,9 @@ 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 Control.Monad.Trans (MonadIO, lift) import Data.Acid as Acid (AcidState, query) import Data.Maybe (isJust) import Data.Monoid ((<>))@@ -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@@ -61,6 +62,7 @@ ~(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 [])]) authenticateInit :: ClckPlugins@@ -75,10 +77,14 @@ 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 } passwordConfig = PasswordConfig { _resetLink = baseUri <> authShowFn ResetPassword [] <> "/#"@@ -87,9 +93,7 @@ } (authCleanup, routeAuthenticate, authenticateState) <- initAuthentication (Just basePath) authenticateConfig- [ initPassword passwordConfig- , initOpenId- ]+ ((initPassword passwordConfig) : if True then [ initOpenId ] else []) addHandler plugins (pluginName authenticatePlugin) (authenticateHandler routeAuthenticate authShowFn) addPluginState plugins (pluginName authenticatePlugin) (AcidStateAuthenticate authenticateState) addCleanup plugins Always authCleanup@@ -134,3 +138,9 @@ case mToken of Nothing -> return Nothing (Just (token, _)) -> return $ Just (token ^. tokenUser ^. userId)++instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) AuthenticateState where+ getAcidState =+ do p <- plugins <$> get+ ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+ pure authenticateState
Clckwrks/Authenticate/Route.hs view
@@ -2,32 +2,56 @@ 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.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 +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
Clckwrks/Authenticate/URL.hs view
@@ -15,6 +15,7 @@ | ResetPassword | ChangePassword | OpenIdRealm+ | AuthModes deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) derivePathInfo ''AuthURL
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/Monad.hs view
@@ -56,7 +56,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(..))@@ -299,7 +299,6 @@ -- | error returned when a reform 'Form' fails to validate data ClckFormError = ClckCFE (CommonFormError [Input])- | PDE ProfileDataError | EmptyUsername deriving (Show) @@ -415,10 +414,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
Clckwrks/Plugin.hs view
@@ -42,9 +42,10 @@ ) 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) []) ] )
Clckwrks/ProfileData/API.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Clckwrks.ProfileData.API ( getProfileData- , getUsername , getUserRoles , requiresRole , requiresRole_ , whoami+ , Role(..) ) where import Clckwrks.Acid (Acid(..))@@ -23,14 +23,12 @@ 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) whoami :: Clck url (Maybe UserId) whoami = getUserId
Clckwrks/ProfileData/Acid.hs view
@@ -2,21 +2,16 @@ module Clckwrks.ProfileData.Acid ( ProfileDataState(..) , initialProfileDataState- , ProfileDataError(..)- , profileDataErrorStr , SetProfileData(..) , GetProfileData(..) , NewProfileData(..)- , GetUsername(..)- , GetUserIdUsernames(..) , 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 +35,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 +81,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 +110,12 @@ 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 , 'getRoles , 'hasRole , 'addRole , 'removeRole- , 'usernameForId- , 'dataForUsername ])
Clckwrks/ProfileData/EditNewProfileData.hs view
@@ -5,18 +5,24 @@ import Clckwrks import Clckwrks.Monad (getRedirectCookie) import Clckwrks.Admin.Template (emptyTemplate)-import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)-import Clckwrks.ProfileData.EditProfileData(profileDataFormlet)+import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin)+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..))+import Clckwrks.ProfileData.EditProfileData(emailFormlet)+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 +32,14 @@ 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 (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+ ~(Just user) <- liftIO $ Acid.query authenticateState (GetUserByUserId uid) action <- showURL here emptyTemplate "Edit Profile Data" () $ <%>- <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>+ <% reform (form action) "epd" updated Nothing (emailFormlet user) %> </%> where updated :: () -> Clck ProfileDataURL Response
Clckwrks/ProfileData/EditProfileData.hs view
@@ -1,20 +1,27 @@-{-# 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 (AcidStateAuthenticate(..), authenticatePlugin)+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 +31,40 @@ 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 (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+ ~(Just user) <- liftIO $ Acid.query authenticateState (GetUserByUserId uid) action <- showURL here- template "Edit Profile Data" () $+ template "Edit Profile Data" () $ [hsx| <%>- <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>+ <% reform (form action) "epd" updated Nothing (emailFormlet user) %> <up-change-password />- </%>+ </%> |] where updated :: () -> Clck ProfileDataURL Response updated () = do seeOtherURL here -profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL ()-profileDataFormlet pd@ProfileData{..} =+emailFormlet :: User -> ClckForm ProfileDataURL ()+emailFormlet u@User{..} = divHorizontal $ errorList ++>- ((,) <$> (divControlGroup (label' "Username" ++> (divControls (inputText username))))- <*> (divControlGroup (label'" Email (optional)" ++> (divControls (inputText (fromMaybe Text.empty email)))))+ ((divControlGroup (label'" Email" ++> (divControls (inputText (maybe Text.empty _unEmail _email))))) <* (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>])+ `transformEitherM` updateEmail+ 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)+ updateEmail :: Text.Text -> Clck ProfileDataURL (Either ClckFormError ())+ updateEmail eml =+ do let user = u { _email = if Text.null eml then Nothing else (Just (Email eml))+ }+ p <- plugins <$> get+ ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+ liftIO $ Acid.update authenticateState (UpdateUser user)+ pure $ Right ()
Clckwrks/ProfileData/EditProfileDataFor.hs view
@@ -4,7 +4,7 @@ import Clckwrks import Clckwrks.Admin.Template (template)-import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..)) import Data.Maybe (fromMaybe) import Data.Set as Set import Data.Text (Text, pack)@@ -32,22 +32,14 @@ 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))+ ((li $ labelText "roles:") ++> (li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) <* inputSubmit (pack "update") ) ) `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)+ updateProfileData :: [Role] -> Clck ProfileDataURL (Either ClckFormError ())+ updateProfileData roles' =+ do let newPd = pd { roles = Set.fromList roles'+ }+ update (SetProfileData newPd)+ pure (Right ())
Clckwrks/ProfileData/Types.hs view
@@ -37,22 +37,34 @@ migrate Visitor_001 = Visitor +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)++$(deriveSafeCopy 1 'base ''ProfileData_1)+ 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 } deriving (Eq, Ord, Read, Show, Data, Typeable) -$(deriveSafeCopy 1 'base ''ProfileData)+$(deriveSafeCopy 2 'extension ''ProfileData) +instance Migrate ProfileData where+ type MigrateFrom ProfileData = ProfileData_1+ migrate (ProfileData_1 df _ _ rs attrs) = ProfileData df rs attrs++ emptyProfileData :: ProfileData emptyProfileData = ProfileData { dataFor = UserId 0- , username = Data.Text.empty- , email = Nothing , roles = Data.Set.empty , attributes = Data.Map.empty }@@ -68,7 +80,6 @@ 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,7 +7,6 @@ -- 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)
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.24.0.15+Version: 0.25.0 Synopsis: A secure, reliable content management system (CMS) and blogging platform Description: clckwrks (pronounced, clockworks) aims to compete directly with popular PHP-based blogging and CMS@@ -46,6 +46,9 @@ Clckwrks.Admin.Console Clckwrks.Admin.Route Clckwrks.Admin.EditSettings+ Clckwrks.Admin.SystemEmails+ Clckwrks.Authenticate.API+ Clckwrks.Authenticate.Page.AuthModes Clckwrks.Authenticate.Page.ChangePassword Clckwrks.Authenticate.Page.Login Clckwrks.Authenticate.Page.OpenIdRealm@@ -104,7 +107,7 @@ containers >= 0.4 && < 0.7, directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5,- happstack-authenticate >= 2.3 && < 2.4,+ happstack-authenticate >= 2.4 && < 2.5, happstack-hsp == 7.3.*, happstack-jmacro >= 7.0 && < 7.1, happstack-server >= 7.0 && < 7.6,