diff --git a/Clckwrks/Acid.hs b/Clckwrks/Acid.hs
--- a/Clckwrks/Acid.hs
+++ b/Clckwrks/Acid.hs
@@ -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
+
diff --git a/Clckwrks/Admin/EditSettings.hs b/Clckwrks/Admin/EditSettings.hs
--- a/Clckwrks/Admin/EditSettings.hs
+++ b/Clckwrks/Admin/EditSettings.hs
@@ -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)
diff --git a/Clckwrks/Admin/Route.hs b/Clckwrks/Admin/Route.hs
--- a/Clckwrks/Admin/Route.hs
+++ b/Clckwrks/Admin/Route.hs
@@ -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)
diff --git a/Clckwrks/Admin/SystemEmails.hs b/Clckwrks/Admin/SystemEmails.hs
new file mode 100644
--- /dev/null
+++ b/Clckwrks/Admin/SystemEmails.hs
@@ -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| <% xml %>
|]])
+ divControlGroup = mapView (\xml -> [[hsx| <% xml %>
|]])
+ divControls = mapView (\xml -> [[hsx| <% xml %>
|]])
+
+ 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 -> [<% xml %>
])
+ divControlGroup = mapView (\xml -> [<% xml %>
])
+ divControls = mapView (\xml -> [<% xml %>
])
+ unUACCT (Just (UACCT str)) = str
+ unUACCT Nothing = ""
+
+ toMUACCT :: String -> Either ClckFormError (Maybe UACCT)
+ toMUACCT [] = Right $ Nothing
+ toMUACCT str = Right $ Just (UACCT str)
+-}
diff --git a/Clckwrks/Admin/URL.hs b/Clckwrks/Admin/URL.hs
--- a/Clckwrks/Admin/URL.hs
+++ b/Clckwrks/Admin/URL.hs
@@ -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)
diff --git a/Clckwrks/Authenticate/API.hs b/Clckwrks/Authenticate/API.hs
new file mode 100644
--- /dev/null
+++ b/Clckwrks/Authenticate/API.hs
@@ -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
diff --git a/Clckwrks/Authenticate/Page/AuthModes.hs b/Clckwrks/Authenticate/Page/AuthModes.hs
new file mode 100644
--- /dev/null
+++ b/Clckwrks/Authenticate/Page/AuthModes.hs
@@ -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|<% xml %>
|]])
+ divControlGroup = mapView (\xml -> [[hsx|<% xml %>
|]])
+ divControls = mapView (\xml -> [[hsx|<% xml %>
|]])
+
+
+-- (divControls (inputText (maybe mempty (_unEmail . _saEmail) _coreFromAddress)) `transformEither` toMaybe))
diff --git a/Clckwrks/Authenticate/Page/Login.hs b/Clckwrks/Authenticate/Page/Login.hs
--- a/Clckwrks/Authenticate/Page/Login.hs
+++ b/Clckwrks/Authenticate/Page/Login.hs
@@ -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
diff --git a/Clckwrks/Authenticate/Plugin.hs b/Clckwrks/Authenticate/Plugin.hs
--- a/Clckwrks/Authenticate/Plugin.hs
+++ b/Clckwrks/Authenticate/Plugin.hs
@@ -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
diff --git a/Clckwrks/Authenticate/Route.hs b/Clckwrks/Authenticate/Route.hs
--- a/Clckwrks/Authenticate/Route.hs
+++ b/Clckwrks/Authenticate/Route.hs
@@ -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
diff --git a/Clckwrks/Authenticate/URL.hs b/Clckwrks/Authenticate/URL.hs
--- a/Clckwrks/Authenticate/URL.hs
+++ b/Clckwrks/Authenticate/URL.hs
@@ -15,6 +15,7 @@
| ResetPassword
| ChangePassword
| OpenIdRealm
+ | AuthModes
deriving (Eq, Ord, Data, Typeable, Generic, Read, Show)
derivePathInfo ''AuthURL
diff --git a/Clckwrks/JS/ClckwrksApp.hs b/Clckwrks/JS/ClckwrksApp.hs
--- a/Clckwrks/JS/ClckwrksApp.hs
+++ b/Clckwrks/JS/ClckwrksApp.hs
@@ -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'
]);
diff --git a/Clckwrks/JS/Route.hs b/Clckwrks/JS/Route.hs
--- a/Clckwrks/JS/Route.hs
+++ b/Clckwrks/JS/Route.hs
@@ -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
diff --git a/Clckwrks/Monad.hs b/Clckwrks/Monad.hs
--- a/Clckwrks/Monad.hs
+++ b/Clckwrks/Monad.hs
@@ -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
diff --git a/Clckwrks/Plugin.hs b/Clckwrks/Plugin.hs
--- a/Clckwrks/Plugin.hs
+++ b/Clckwrks/Plugin.hs
@@ -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) [])
]
)
diff --git a/Clckwrks/ProfileData/API.hs b/Clckwrks/ProfileData/API.hs
--- a/Clckwrks/ProfileData/API.hs
+++ b/Clckwrks/ProfileData/API.hs
@@ -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
diff --git a/Clckwrks/ProfileData/Acid.hs b/Clckwrks/ProfileData/Acid.hs
--- a/Clckwrks/ProfileData/Acid.hs
+++ b/Clckwrks/ProfileData/Acid.hs
@@ -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
])
diff --git a/Clckwrks/ProfileData/EditNewProfileData.hs b/Clckwrks/ProfileData/EditNewProfileData.hs
--- a/Clckwrks/ProfileData/EditNewProfileData.hs
+++ b/Clckwrks/ProfileData/EditNewProfileData.hs
@@ -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
diff --git a/Clckwrks/ProfileData/EditProfileData.hs b/Clckwrks/ProfileData/EditProfileData.hs
--- a/Clckwrks/ProfileData/EditProfileData.hs
+++ b/Clckwrks/ProfileData/EditProfileData.hs
@@ -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) %>
-
+ |]
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 -> [<% xml %>
])
- divControlGroup = mapView (\xml -> [<% xml %>
])
- divControls = mapView (\xml -> [<% xml %>
])
+ `transformEitherM` updateEmail
+ where
+ label' :: Text -> ClckForm ProfileDataURL ()
+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])
+ divHorizontal = mapView (\xml -> [[hsx|<% xml %>
|]])
+ divControlGroup = mapView (\xml -> [[hsx|<% xml %>
|]])
+ divControls = mapView (\xml -> [[hsx|<% xml %>
|]])
- 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 ()
diff --git a/Clckwrks/ProfileData/EditProfileDataFor.hs b/Clckwrks/ProfileData/EditProfileDataFor.hs
--- a/Clckwrks/ProfileData/EditProfileDataFor.hs
+++ b/Clckwrks/ProfileData/EditProfileDataFor.hs
@@ -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 ())
diff --git a/Clckwrks/ProfileData/Types.hs b/Clckwrks/ProfileData/Types.hs
--- a/Clckwrks/ProfileData/Types.hs
+++ b/Clckwrks/ProfileData/Types.hs
@@ -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
diff --git a/Clckwrks/Route.hs b/Clckwrks/Route.hs
--- a/Clckwrks/Route.hs
+++ b/Clckwrks/Route.hs
@@ -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
diff --git a/Clckwrks/Server.hs b/Clckwrks/Server.hs
--- a/Clckwrks/Server.hs
+++ b/Clckwrks/Server.hs
@@ -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)
diff --git a/clckwrks.cabal b/clckwrks.cabal
--- a/clckwrks.cabal
+++ b/clckwrks.cabal
@@ -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,