clckwrks 0.25.2 → 0.25.4
raw patch · 7 files changed
+91/−40 lines, 7 filesdep ~acid-statedep ~happstack-serverdep ~happstack-server-tls
Dependency ranges changed: acid-state, happstack-server, happstack-server-tls, lens
Files
- Clckwrks/Acid.hs +19/−3
- Clckwrks/Monad.hs +8/−1
- Clckwrks/ProfileData/API.hs +3/−0
- Clckwrks/ProfileData/EditNewProfileData.hs +3/−2
- Clckwrks/ProfileData/EditProfileData.hs +14/−9
- Clckwrks/ProfileData/Types.hs +38/−19
- clckwrks.cabal +6/−6
Clckwrks/Acid.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} module Clckwrks.Acid where import Clckwrks.NavBar.Acid (NavBarState , initialNavBarState)@@ -14,14 +14,19 @@ import Control.Monad.State (modify, put) import Data.Acid (AcidState, Query, Update, createArchive, makeAcidic) import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose)+#if MIN_VERSION_acid_state (0,16,0)+import Data.Acid.Remote (acidServerSockAddr, skipAuthenticationCheck)+import Network.Socket (SockAddr(SockAddrUnix))+#else import Data.Acid.Remote (acidServer, skipAuthenticationCheck)+import Network (PortID(UnixSocket))+#endif import Data.Data (Data, Typeable) import Data.Maybe (fromMaybe) import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.Text (Text)-import Happstack.Authenticate.Core (AuthenticateState, SimpleAddress(..))+import Happstack.Authenticate.Core (AuthenticateState, SimpleAddress(..)) import Happstack.Authenticate.Password.Core (PasswordState)-import Network (PortID(UnixSocket)) import Prelude hiding (catch) import System.Directory (removeFile) import System.FilePath ((</>))@@ -199,10 +204,21 @@ bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createArchiveCheckpointAndClose) $ \profileData -> bracket (openLocalStateFrom (basePath </> "navBar") initialNavBarState) (createArchiveCheckpointAndClose) $ \navBar -> -- create sockets to allow `clckwrks-cli` to talk to the databases+#if MIN_VERSION_acid_state (0,16,0)+ bracket (forkIO (tryRemoveFile (basePath </> "core_socket") >> acidServerSockAddr skipAuthenticationCheck (SockAddrUnix $ basePath </> "core_socket") profileData))+ (\tid -> killThread tid >> tryRemoveFile (basePath </> "core_socket")) $ const $++#else bracket (forkIO (tryRemoveFile (basePath </> "core_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "core_socket") profileData)) (\tid -> killThread tid >> tryRemoveFile (basePath </> "core_socket")) $ const $+#endif+#if MIN_VERSION_acid_state (0,16,0)+ bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServerSockAddr skipAuthenticationCheck (SockAddrUnix $ basePath </> "profileData_socket") profileData))+ (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket"))+#else bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "profileData_socket") profileData)) (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket"))+#endif (const $ f (Acid profileData core navBar)) where tryRemoveFile fp = removeFile fp `catch` (\e -> if isDoesNotExistError e then return () else throw e)
Clckwrks/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings, TemplateHaskell #-} module Clckwrks.Monad ( Clck , ClckPlugins@@ -64,6 +64,9 @@ import Clckwrks.Unauthorized (unauthorizedPage) import Clckwrks.URL (ClckURL(..)) import Control.Applicative (Alternative, Applicative, (<$>), (<|>), many, optional)+#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0)+import Control.Monad.Fail (MonadFail)+#endif import Control.Monad (MonadPlus, foldM) import Control.Monad.State (MonadState, StateT, evalStateT, execStateT, get, mapStateT, modify, put, runStateT) import Control.Monad.Reader (MonadReader, ReaderT, mapReaderT)@@ -249,7 +252,11 @@ ------------------------------------------------------------------------------ newtype ClckT url m a = ClckT { unClckT :: RouteT url (StateT ClckState m) a }+#ifdef MIN_VERSION_base(4,9,0)+ deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadFail, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState)+#else deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState)+#endif instance (Happstack m) => Happstack (ClckT url m)
Clckwrks/ProfileData/API.hs view
@@ -30,6 +30,9 @@ getProfileData :: UserId -> Clck url ProfileData getProfileData uid = query (GetProfileData uid) +getDisplayName :: UserId -> Clck url (Maybe DisplayName)+getDisplayName uid = displayName <$> query (GetProfileData uid)+ whoami :: Clck url (Maybe UserId) whoami = getUserId
Clckwrks/ProfileData/EditNewProfileData.hs view
@@ -7,7 +7,7 @@ import Clckwrks.Admin.Template (emptyTemplate) import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin) import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..))-import Clckwrks.ProfileData.EditProfileData(emailFormlet)+import Clckwrks.ProfileData.EditProfileData(profileDataFormlet) import Control.Monad.State (get) import Control.Monad.Trans (liftIO) import qualified Data.Acid as Acid@@ -36,10 +36,11 @@ p <- plugins <$> get ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin) ~(Just user) <- liftIO $ Acid.query authenticateState (GetUserByUserId uid)+ pd <- query (GetProfileData uid) action <- showURL here emptyTemplate "Edit Profile Data" () $ <%>- <% reform (form action) "epd" updated Nothing (emailFormlet user) %>+ <% reform (form action) "epd" updated Nothing (profileDataFormlet user pd) %> </%> where updated :: () -> Clck ProfileDataURL Response
Clckwrks/ProfileData/EditProfileData.hs view
@@ -35,10 +35,11 @@ p <- plugins <$> get ~(Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin) ~(Just user) <- liftIO $ Acid.query authenticateState (GetUserByUserId uid)+ pd <- query (GetProfileData uid) action <- showURL here template "Edit Profile Data" () $ [hsx| <%>- <% reform (form action) "epd" updated Nothing (emailFormlet user) %>+ <% reform (form action) "epd" updated Nothing (profileDataFormlet user pd) %> -- <div ng-controller="UsernamePasswordCtrl"> -- <up-change-password /> -- </div>@@ -48,13 +49,15 @@ updated () = do seeOtherURL here -emailFormlet :: User -> ClckForm ProfileDataURL ()-emailFormlet u@User{..} =+profileDataFormlet :: User -> ProfileData -> ClckForm ProfileDataURL ()+profileDataFormlet u@User{..} pd = divHorizontal $ errorList ++>- ((divControlGroup (label'" Email" ++> (divControls (inputText (maybe Text.empty _unEmail _email)))))- <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` (("class" := "btn") :: Attr Text Text)))))- `transformEitherM` updateEmail+ ((,) <$> (divControlGroup (label' "Email" ++> (divControls (inputText (maybe Text.empty _unEmail _email)))))+ <*> (divControlGroup (label' "DisplayName" ++> (divControls (inputText (maybe Text.empty unDisplayName (displayName pd))))))+ <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` (("class" := "btn") :: Attr Text Text))))+ )+ `transformEitherM` updateProfileData where label' :: Text -> ClckForm ProfileDataURL () label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])@@ -62,11 +65,13 @@ divControlGroup = mapView (\xml -> [[hsx|<div class="control-group"><% xml %></div>|]]) divControls = mapView (\xml -> [[hsx|<div class="controls"><% xml %></div>|]]) - updateEmail :: Text.Text -> Clck ProfileDataURL (Either ClckFormError ())- updateEmail eml =- do let user = u { _email = if Text.null eml then Nothing else (Just (Email eml))+ updateProfileData :: (Text.Text, Text.Text) -> Clck ProfileDataURL (Either ClckFormError ())+ updateProfileData (eml, dn) =+ do let user = u { _email = if Text.null eml then Nothing else (Just (Email eml)) } p <- plugins <$> get ~(Just (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) })) pure $ Right ()
Clckwrks/ProfileData/Types.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeFamilies #-} module Clckwrks.ProfileData.Types- ( ProfileData(..)+ ( DisplayName(..)+ , ProfileData(..) , Role(..) , defaultProfileDataFor , emptyProfileData@@ -16,11 +17,12 @@ import Data.Text (Text, empty) import Data.Typeable (Typeable) import Data.UserId (UserId(..))+import GHC.Generics (Generic) data Role_001 = Administrator_001 | Visitor_001- deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded)+ deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded, Generic) $(deriveSafeCopy 1 'base ''Role_001) data Role@@ -28,7 +30,7 @@ | Visitor | Moderator | Editor- deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded)+ deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded, Generic) $(deriveSafeCopy 2 'extension ''Role) instance Migrate Role where@@ -36,7 +38,13 @@ migrate Administrator_001 = Administrator migrate Visitor_001 = Visitor +newtype Username = Username { unUsername :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +newtype DisplayName = DisplayName { unDisplayName :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+$(deriveSafeCopy 1 'base ''DisplayName)+ data ProfileData_1 = ProfileData_1 { dataFor_1 :: UserId , username_1 :: Text -- ^ now comes from happstack-authenticate@@ -44,29 +52,43 @@ , roles_1 :: Set Role , attributes_1 :: Map Text Text }- deriving (Eq, Ord, Read, Show, Data, Typeable)+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) $(deriveSafeCopy 1 'base ''ProfileData_1) +data ProfileData_2 = ProfileData_2+ { dataFor_2 :: UserId+ , roles_2 :: Set Role+ , attributes_2 :: Map Text Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)++$(deriveSafeCopy 2 'extension ''ProfileData_2)++instance Migrate ProfileData_2 where+ type MigrateFrom ProfileData_2 = ProfileData_1+ migrate (ProfileData_1 df _ _ rs attrs) = ProfileData_2 df rs attrs+ data ProfileData = ProfileData- { dataFor :: UserId- , roles :: Set Role- , attributes :: Map Text Text+ { dataFor :: UserId+ , displayName :: Maybe DisplayName+ , roles :: Set Role+ , attributes :: Map Text Text }- deriving (Eq, Ord, Read, Show, Data, Typeable)+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) -$(deriveSafeCopy 2 'extension ''ProfileData)+$(deriveSafeCopy 3 'extension ''ProfileData) instance Migrate ProfileData where- type MigrateFrom ProfileData = ProfileData_1- migrate (ProfileData_1 df _ _ rs attrs) = ProfileData df rs attrs-+ type MigrateFrom ProfileData = ProfileData_2+ migrate (ProfileData_2 df rs attrs) = ProfileData df Nothing rs attrs emptyProfileData :: ProfileData emptyProfileData = ProfileData- { dataFor = UserId 0- , roles = Data.Set.empty- , attributes = Data.Map.empty+ { dataFor = UserId 0+ , displayName = Nothing+ , roles = Data.Set.empty+ , attributes = Data.Map.empty } defaultProfileDataFor :: UserId -> ProfileData@@ -74,9 +96,6 @@ emptyProfileData { dataFor = uid , roles = singleton Visitor }--newtype Username = Username { unUsername :: Text }- deriving (Eq, Ord, Read, Show, Data, Typeable) instance Indexable ProfileData where empty = ixSet [ ixFunS dataFor
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.25.2+Version: 0.25.4 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@@ -21,7 +21,7 @@ Category: Clckwrks Build-type: Custom Cabal-version: >=1.18-tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.6.3+tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.6.3, GHC == 8.8.1 Data-Files: static/admin.css @@ -96,7 +96,7 @@ build-depends: network < 2.6 Build-depends:- acid-state >= 0.12 && < 0.16,+ acid-state >= 0.12 && < 0.17, aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.5), aeson-qq >= 0.7 && < 0.9, attoparsec >= 0.10 && < 0.14,@@ -110,14 +110,14 @@ happstack-authenticate >= 2.4 && < 2.5, happstack-hsp == 7.3.*, happstack-jmacro >= 7.0 && < 7.1,- happstack-server >= 7.0 && < 7.6,- happstack-server-tls >= 7.1 && < 7.2,+ happstack-server >= 7.0 && < 7.7,+ happstack-server-tls >= 7.1 && < 7.3, hsp >= 0.9 && < 0.11, hsx-jmacro == 7.3.*, hsx2hs >= 0.13 && < 0.15, ixset >= 1.0 && < 1.2, jmacro == 0.6.*,- lens >= 4.3 && < 4.18,+ lens >= 4.3 && < 4.19, mtl >= 2.0 && < 2.3, old-locale == 1.0.*, process >= 1.0 && < 1.7,