clckwrks 0.26.4 → 0.27.1

raw patch · 12 files changed

+167/−42 lines, 12 filesdep ~happstack-authenticatePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: happstack-authenticate

API changes (from Hackage documentation)

Files

• Clckwrks/Admin/Route.hs +1/−0
• Clckwrks/Authenticate/API.hs +4/−3
• Clckwrks/Authenticate/Monad.hs +30/−0
• Clckwrks/Authenticate/Page/ChangePassword.hs +1/−1
• Clckwrks/Authenticate/Page/ViewUsers.hs +37/−0
• Clckwrks/Authenticate/Plugin.hs +13/−18
• Clckwrks/Authenticate/Route.hs +3/−0
• Clckwrks/Authenticate/URL.hs +1/−0
• Clckwrks/ProfileData/EditNewProfileData.hs +3/−2
• Clckwrks/ProfileData/EditProfileData.hs +4/−3
• Clckwrks/ProfileData/EditProfileDataFor.hs +66/−13
• clckwrks.cabal +4/−2

@@ -15,3 +15,4 @@       EditNavBar        -> editNavBar       NavBarPost        -> navBarPost       SystemEmails      -> systemEmailsPage (Admin url)+

@@ -11,7 +11,8 @@ import Control.Monad                (join) import Control.Monad.State          (get) import Control.Monad.Trans          (liftIO)-import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin)+import Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.Monad  (AcidStateAuthenticate(..)) import Data.Acid as Acid            (AcidState, query, update) import Data.Maybe                   (maybe) import Data.Monoid                  (mempty)@@ -23,7 +24,7 @@ getUser :: UserId -> Clck url (Maybe User) getUser uid =   do p <- plugins <$> get-     ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+     ~(Just (AcidStateAuthenticate authenticateState _)) <- getPluginState p (pluginName authenticatePlugin)      liftIO $ Acid.query authenticateState (GetUserByUserId uid)  -- | Update an existing 'User'. Must already have a valid 'UserId'.@@ -33,7 +34,7 @@ insecureUpdateUser :: User -> Clck url () insecureUpdateUser user =   do p <- plugins <$> get-     ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+     ~(Just (AcidStateAuthenticate authenticateState _)) <- getPluginState p (pluginName authenticatePlugin)      liftIO $ Acid.update authenticateState (UpdateUser user)  getUsername :: UserId -> Clck url (Maybe Username)

@@ -0,0 +1,30 @@+{-# 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.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(..), getToken, tokenUser, userId, usernamePolicy)+import Happstack.Authenticate.Password.Core (PasswordState)+import Web.Plugins.Core            (getPluginState)++data AcidStateAuthenticate = AcidStateAuthenticate+  { acidStateAuthenticate :: AcidState AuthenticateState+  , acidStatePassword     :: AcidState PasswordState                                                }+  deriving Typeable++instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) AuthenticateState where+    getAcidState =+      do p <- plugins <$> get+         ~(Just (AcidStateAuthenticate authenticateState _)) <- getPluginState p "authenticate"+         pure authenticateState++instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) PasswordState where+    getAcidState =+      do p <- plugins <$> get+         ~(Just (AcidStateAuthenticate _ passwordState)) <- getPluginState p "authenticate"+         pure passwordState+

@@ -9,7 +9,7 @@  changePasswordPanel :: ClckT ClckURL (ServerPartT IO) Response changePasswordPanel =-    do template "Change Password" () $ [hsx|+  do template "Change Password" () $ [hsx|         <%>          <h2>Change Password</h2>          <div ng-controller="UsernamePasswordCtrl">

@@ -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> |]+

@@ -3,6 +3,7 @@  import Clckwrks.Monad import Clckwrks.Acid               (GetAcidState(..), GetCoreState(..), GetEnableOpenId(..), acidCore, acidProfileData, coreFromAddress, coreReplyToAddress, coreSendmailPath, getAcidState)+import Clckwrks.Authenticate.Monad (AcidStateAuthenticate(..)) import Clckwrks.Authenticate.Route (routeAuth) import Clckwrks.Authenticate.URL   (AuthURL(..)) import Clckwrks.ProfileData.Acid   (HasRole(..))@@ -14,7 +15,7 @@ import Control.Monad.Reader        (ask) import Control.Monad.State         (get) import Control.Monad.Trans         (MonadIO, lift)-import Data.Acid as Acid           (AcidState, query)+import Data.Acid as Acid           (AcidState, query, openLocalStateFrom) import Data.Maybe                  (isJust) import Data.Monoid                 ((<>)) import qualified Data.Set          as Set@@ -26,17 +27,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 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)@@ -60,9 +58,10 @@ addAuthAdminMenu =     do p <- plugins <$> get        ~(Just authShowURL) <- getPluginRouteFn p (pluginName authenticatePlugin)-       addAdminMenu ("Authentication", [(Set.fromList [Visitor]      , "Change Password", authShowURL ChangePassword [])])-       addAdminMenu ("Authentication", [(Set.fromList [Administrator], "OpenId Realm"   , authShowURL OpenIdRealm    [])])-       addAdminMenu ("Authentication", [(Set.fromList [Administrator], "Authentication Modes", authShowURL AuthModes [])])+       addAdminMenu ("Authentication", [(Set.fromList [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@@ -92,10 +91,11 @@                           , _passwordAcceptable = const Nothing                           } +     passwordState <- openLocalStateFrom (combine basePath "password") initialPasswordState      (authCleanup, routeAuthenticate, authenticateState) <- initAuthentication (Just basePath) authenticateConfig-        ((initPassword passwordConfig) : if True then [ initOpenId ] else [])+        ((initPassword' passwordConfig passwordState) : if True then [ initOpenId ] else [])      addHandler     plugins (pluginName authenticatePlugin) (authenticateHandler routeAuthenticate authShowFn)-     addPluginState plugins (pluginName authenticatePlugin) (AcidStateAuthenticate authenticateState)+     addPluginState plugins (pluginName authenticatePlugin) (AcidStateAuthenticate authenticateState passwordState)      addCleanup plugins Always authCleanup      return Nothing {-@@ -133,14 +133,9 @@ getUserId :: (Happstack m) => ClckT url m (Maybe UserId) getUserId =   do p <- plugins <$> get-     ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+     ~(Just (AcidStateAuthenticate authenticateState _)) <- getPluginState p (pluginName authenticatePlugin)      mToken <- getToken authenticateState      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

@@ -9,6 +9,7 @@ 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)@@ -40,6 +41,7 @@        ChangePassword -> withClckURL changePasswordPanel        OpenIdRealm    -> withClckURL openIdRealmPanel        AuthModes      -> authModesPage u+       ViewUsers      -> withClckURL viewUsers  checkAuth :: (Happstack m, Monad m) =>              AuthURL@@ -55,3 +57,4 @@        AuthModes      -> requiresRole (Set.fromList [Administrator]) url        ChangePassword -> requiresRole (Set.fromList [Visitor]) url        OpenIdRealm    -> requiresRole (Set.fromList [Administrator]) url+       ViewUsers      -> requiresRole (Set.fromList [Administrator]) url

@@ -16,6 +16,7 @@   | ChangePassword   | OpenIdRealm   | AuthModes+  | ViewUsers   deriving (Eq, Ord, Data, Typeable, Generic, Read, Show)  derivePathInfo ''AuthURL

@@ -5,7 +5,8 @@ import Clckwrks import Clckwrks.Monad              (getRedirectCookie) import Clckwrks.Admin.Template     (emptyTemplate)-import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin)+import Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.Monad (AcidStateAuthenticate(..)) import Clckwrks.ProfileData.Acid   (GetProfileData(..), SetProfileData(..)) import Clckwrks.ProfileData.EditProfileData(profileDataFormlet) import Control.Monad.State         (get)@@ -34,7 +35,7 @@          (Just uid) ->              do -- pd <- query (GetProfileData uid)                 p <- plugins <$> get-                ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+                ~(Just (AcidStateAuthenticate authenticateState _)) <- getPluginState p (pluginName authenticatePlugin)                 ~(Just user) <- liftIO $ Acid.query authenticateState (GetUserByUserId uid)                 pd <- query (GetProfileData uid)                 action <- showURL here

@@ -4,7 +4,8 @@ import Clckwrks import Clckwrks.Monad              (plugins) import Clckwrks.Admin.Template     (template)-import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin)+import Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.Authenticate.Monad (AcidStateAuthenticate(..)) import Clckwrks.ProfileData.Acid   (GetProfileData(..), SetProfileData(..)) import Control.Monad.State         (get) import Control.Monad.Trans         (liftIO)@@ -33,7 +34,7 @@          (Just uid) ->              do -- pd <- query (GetProfileData uid)                 p <- plugins <$> get-                ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin)+                ~(Just (AcidStateAuthenticate authenticateState _)) <- getPluginState p (pluginName authenticatePlugin)                 ~(Just user) <- liftIO $ Acid.query authenticateState (GetUserByUserId uid)                 pd <- query (GetProfileData uid)                 action <- showURL here@@ -70,7 +71,7 @@       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)+         ~(Just (AcidStateAuthenticate authenticateState _)) <- getPluginState p (pluginName authenticatePlugin)          liftIO $ Acid.update authenticateState  (UpdateUser user)          pd <- query (GetProfileData _userId)          update (SetProfileData (pd { displayName = if Text.null dn then Nothing else Just (DisplayName dn) }))

@@ -1,45 +1,98 @@-{-# 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(..))+import Clckwrks.Authenticate.Monad () import Data.Maybe               (fromMaybe) import Data.Set                 as Set-import Data.Text                (Text, pack)+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) import HSP.XMLGenerator import HSP.XML-import Text.Reform              ((++>), transformEitherM)+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)  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) %>+               </div>+               |]     where       updated :: () -> Clck ProfileDataURL Response       updated () =           do seeOtherURL here +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 "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+      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))

@@ -1,5 +1,5 @@ Name:                clckwrks-Version:             0.26.4+Version:             0.27.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@@ -46,11 +46,13 @@                    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@@ -105,7 +107,7 @@      containers                   >= 0.4  && < 0.7,      directory                    >= 1.1  && < 1.4,      filepath                     >= 1.2  && < 1.5,-     happstack-authenticate       >= 2.4  && < 2.5,+     happstack-authenticate       >= 2.4.2  && < 2.5,      happstack-hsp                == 7.3.*,      happstack-jmacro             >= 7.0  && < 7.1,      happstack-server             >= 7.0  && < 7.8,