cqrs-example 0.7.1 → 0.8.0
raw patch · 13 files changed
+622/−546 lines, 13 filesdep +base64-bytestringdep +blaze-builderdep +case-insensitivedep −enumeratordep −happstack-litedep −happstack-serverdep ~cqrsdep ~cqrs-sqlite3
Dependencies added: base64-bytestring, blaze-builder, case-insensitive, conduit, http-types, safecopy, strict-concurrency, wai, wai-app-static, wai-eventsource, wai-extra, warp
Dependencies removed: enumerator, happstack-lite, happstack-server, happstack-util
Dependency ranges changed: cqrs, cqrs-sqlite3
Files
- cqrs-example.cabal +25/−12
- src/CQRSExample/Aggregates.hs +18/−107
- src/CQRSExample/Command.hs +14/−11
- src/CQRSExample/Controller/Auth.hs +0/−30
- src/CQRSExample/Duration.hs +40/−0
- src/CQRSExample/Events.hs +35/−84
- src/CQRSExample/Instances.hs +74/−56
- src/CQRSExample/Json.hs +39/−150
- src/CQRSExample/Main.hs +47/−32
- src/CQRSExample/Query.hs +88/−64
- src/CQRSExample/Wai.hs +108/−0
- src/CQRSExample/WaiAuth.hs +38/−0
- src/CQRSExample/WaiParameters.hs +96/−0
cqrs-example.cabal view
@@ -1,5 +1,5 @@ Name: cqrs-example-Version: 0.7.1+Version: 0.8.0 Synopsis: Example for cqrs package Description: Example for cqrs package License: MIT@@ -15,35 +15,47 @@ Ghc-options: -Wall Build-depends: base == 4.* , aeson >= 0.3.2.12 && <0.4+ , base64-bytestring >= 0.1 && <0.2+ , blaze-builder >= 0.3 && <0.4 , bytestring >= 0.9 && < 0.10+ , case-insensitive >= 0.2 && < 0.3 , cereal >= 0.3 && < 0.4+ , conduit >= 0.1 && < 0.2 , containers >= 0.4 && < 0.5 , convertible >= 1.0.11.0 && < 1.1- , cqrs >= 0.7.1 && < 0.8- , cqrs-sqlite3 >= 0.7.1 && < 0.8+ , cqrs >= 0.8.0 && < 0.9+ , cqrs-sqlite3 >= 0.8.0 && < 0.9 , data-default >= 0.3 && < 0.4- , enumerator >= 0.4.15 && < 0.5- , happstack-lite >= 6.0 && < 7.0- , happstack-server >= 6.3 && < 7.0- , happstack-util >= 6.0 && < 7.0 , HDBC >= 2.3.1.0 && < 2.4 , HDBC-sqlite3 >= 2.3.3.0 && < 2.4+ , http-types >= 0.6 && <0.7 , old-locale >= 1.0 && < 1.1+ , safecopy >= 0.6 && <0.7+ , strict-concurrency >= 0.2 && < 0.3 , text >= 0.11 && < 0.12 , time >= 1.2 && < 1.3 , transformers >= 0.2.2 && < 0.3+ , wai >= 1.0.0 && < 1.1+ , wai-app-static >= 1.0 && < 1.1+ , wai-eventsource >= 1.0 && < 1.1+ , wai-extra >= 1.0 && < 1.1+ , warp >= 1.0.0 && < 1.1 Default-extensions: DeriveDataTypeable MultiParamTypeClasses OverloadedStrings ScopedTypeVariables+ TemplateHaskell Hs-source-dirs: src Other-modules: CQRSExample.Aggregates CQRSExample.Command- CQRSExample.Controller.Auth+ CQRSExample.Duration CQRSExample.Events CQRSExample.Instances CQRSExample.Json CQRSExample.Query+ CQRSExample.Wai+ CQRSExample.WaiAuth+ CQRSExample.WaiParameters Default-language: Haskell2010 Test-Suite cqrs-example-tests@@ -53,12 +65,13 @@ build-depends: base == 4.* , bytestring >= 0.9 && < 0.10 , cereal >= 0.3 && < 0.4+ , conduit >= 0.1 && < 0.2 , containers >= 0.4 && < 0.5- , cqrs >= 0.7.1 && < 0.8- , cqrs-sqlite3 >= 0.7.1 && < 0.8+ , cqrs >= 0.8.0 && < 0.9+ , cqrs-sqlite3 >= 0.8.0 && < 0.9 , data-default >= 0.3 && < 0.4 , direct-sqlite >= 1.1 && < 1.2- , enumerator >= 0.4.15 && < 0.5+ , safecopy >= 0.6 && <0.7 , text >= 0.11 && < 0.12 , time >= 1.2 && < 1.3 , transformers >= 0.2.2 && < 0.3@@ -74,4 +87,4 @@ MultiParamTypeClasses OverloadedStrings ScopedTypeVariables-+ TemplateHaskell
src/CQRSExample/Aggregates.hs view
@@ -11,33 +11,18 @@ , WorkUnitId ) where -import Control.Monad (liftM)+import CQRSExample.Duration (Duration) import Data.CQRS (Aggregate(..), GUID)-import Data.CQRS.Serialize (decode')+import Data.CQRS.Serialize (decode', encode) import Data.Default (Default(..)) import Data.Map (Map)+import Data.SafeCopy (base, deriveSafeCopySimple) import Data.Set (Set) import qualified Data.Set as S-import Data.Serialize (Serialize(..), encode) import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Time.Calendar(Day(..), toGregorian, fromGregorian)+import Data.Time.Calendar(Day(..)) import Data.Typeable (Typeable)-import Data.Word (Word8) --- Instances for Haskell built-ins.-instance Serialize Day where- put = put . toGregorian- get = do- (a,b,c) <- get- return $ fromGregorian a b c---- Instance for Text. We'll just serialize all of it as UTF-8,--- there's very little point in doing otherwise for our use case.-instance Serialize Text where- put = put . encodeUtf8- get = fmap decodeUtf8 get- -- Site aggregate. This keeps track of things which must be "per site" -- (per installation), e.g. a list of used user names such that we -- can be sure that there are no users with the same login name.@@ -47,12 +32,6 @@ data Site = Site { sUserNames :: Set Text } deriving (Typeable, Eq, Show) -instance Serialize Site where- put (Site suns) =- put suns- get = do- fmap Site get- instance Aggregate Site where encodeAggregate = encode decodeAggregate = decode'@@ -68,42 +47,24 @@ type ProjectId = GUID -data Project = DefaultProject+data Project = UninitializedProject | ActiveProject { projectName :: Text , projectCustomer :: Text } deriving (Typeable, Eq, Show) -instance Serialize Project where- put DefaultProject = do- put (0 :: Word8)- put (ActiveProject pn pc) = do- put (1 :: Word8)- put $ encodeUtf8 pn- put $ encodeUtf8 pc- get = do- i :: Word8 <- get- case i of- 0 -> return DefaultProject- 1 -> do- pn <- liftM decodeUtf8 get- pc <- liftM decodeUtf8 get- return $ ActiveProject pn pc- _ ->- fail $ "Cannot decode project state" ++ show i- instance Aggregate Project where encodeAggregate = encode decodeAggregate = decode' instance Default Project where- def = DefaultProject+ def = UninitializedProject -- Tasks. type TaskId = GUID -data Task = NewTask+data Task = UninitializedTask | ActiveTask { taskProjectId :: ProjectId , taskShortDescription :: Text , taskLongDescription :: Text@@ -111,41 +72,18 @@ } deriving (Typeable, Eq, Show) -instance Serialize Task where- put NewTask = do- put (0 :: Word8)- put (ActiveTask tpid tsd tld twu) = do- put (1 :: Word8)- put tpid- put $ encodeUtf8 tsd- put $ encodeUtf8 tld- put twu- get = do- i :: Word8 <- get- case i of- 0 -> return NewTask- 1 -> do- tpid <- get- tsd <- liftM decodeUtf8 get- tld <- liftM decodeUtf8 get- twu <- get- return $ ActiveTask tpid tsd tld twu- _ ->- fail $ "Cannot decode task state: " ++ show i-- instance Aggregate Task where encodeAggregate = encode decodeAggregate = decode' instance Default Task where- def = NewTask+ def = UninitializedTask -- Users. type UserId = GUID -data User = UncreatedUser+data User = UninitializedUser | ActiveUser { auUserName :: Text , auPassword :: Text , auLastName :: Text@@ -153,34 +91,12 @@ } deriving (Typeable, Eq, Show) -instance Serialize User where- put UncreatedUser = do- put $ (0 :: Word8)- put (ActiveUser auun aupw auln aufn) = do- put $ (1 :: Word8)- put $ encodeUtf8 auun- put $ encodeUtf8 aupw- put $ encodeUtf8 auln- put $ encodeUtf8 aufn- get = do- i :: Word8 <- get- case i of- 0 -> return UncreatedUser- 1 -> do- auun <- liftM decodeUtf8 get- aupw <- liftM decodeUtf8 get- auln <- liftM decodeUtf8 get- aufn <- liftM decodeUtf8 get- return $ ActiveUser auun aupw auln aufn- _ ->- fail $ "Cannot decode user state: " ++ show i- instance Aggregate User where encodeAggregate = encode decodeAggregate = decode' instance Default User where- def = UncreatedUser+ def = UninitializedUser -- Work Units (NOT aggregates!)@@ -188,20 +104,15 @@ data WorkUnit = WorkUnit { workUnitId :: GUID , workUnitComment :: Text- , workUnitDuration :: Integer+ , workUnitDuration :: Duration , workUnitUser :: UserId } deriving (Eq, Show) -instance Serialize WorkUnit where- put (WorkUnit wuid wuc wud wuu) = do- put $ wuid- put $ encodeUtf8 wuc- put wud- put wuu- get = do- wuid <- get- wuc <- liftM decodeUtf8 get- wud <- get- wuu <- get- return $ WorkUnit wuid wuc wud wuu+-- SafeCopy instances.++$(deriveSafeCopySimple 1 'base ''Task)+$(deriveSafeCopySimple 1 'base ''Site)+$(deriveSafeCopySimple 1 'base ''Project)+$(deriveSafeCopySimple 1 'base ''User)+$(deriveSafeCopySimple 1 'base ''WorkUnit)
src/CQRSExample/Command.hs view
@@ -12,12 +12,14 @@ import Control.Monad (when, void) import Control.Monad.Trans.Class (lift) import CQRSExample.Aggregates+import CQRSExample.Duration (Duration) import CQRSExample.Events import CQRSExample.Instances () import Data.CQRS import qualified Data.Set as S import Data.Text (Text) import Data.Time.Calendar (Day)+import Data.Time.Clock (getCurrentTime) -- Perform any needed site initialization. siteInitialization :: TransactionT Event IO ()@@ -34,11 +36,11 @@ (siteRef, site :: Site) <- getAggregateRoot siteGUID when (S.member userName $ sUserNames site) $ fail $ "User already exists: " ++ (show userName) -- Add user to site aggregate.- publishEvent siteRef $ UserRegistered userName+ publishEvent siteRef $ SiteEvent $ UserRegistered userName -- Publish to the user aggregate. userId <- lift $ newGUID (userRef, _ :: User) <- getAggregateRoot userId- publishEvent userRef $ UserCreated userName password firstName lastName+ publishEvent userRef $ UserEvent $ UserCreated userName password firstName lastName return userId -- Create a new project.@@ -46,43 +48,44 @@ createProject name shortDescription = do projectId <- lift $ newGUID (projectRef, _ :: Project) <- getAggregateRoot projectId- publishEvent projectRef $ ProjectCreated name shortDescription+ publishEvent projectRef $ ProjectEvent $ ProjectCreated name shortDescription return projectId -- Rename project. renameProject :: ProjectId -> Text -> TransactionT Event IO () renameProject projectId newName = do (projectRef, _ :: Project) <- getAggregateRoot projectId- publishEvent projectRef $ ProjectRenamed newName+ publishEvent projectRef $ ProjectEvent $ ProjectRenamed newName -- Create new task in a project.-createTask :: ProjectId -> Text -> TransactionT Event IO TaskId-createTask projectId shortDescription = do+createTask :: ProjectId -> Text -> Duration -> UserId -> TransactionT Event IO TaskId+createTask projectId shortDescription estimate userId = do taskId <- lift $ newGUID (taskRef, _ :: Task) <- getAggregateRoot taskId- publishEvent taskRef $ TaskAdded projectId shortDescription+ ts <- lift $ getCurrentTime+ publishEvent taskRef $ TaskEvent $ TaskAdded projectId shortDescription estimate userId ts return taskId -- Star a task. starTask :: TaskId -> UserId -> TransactionT Event IO () starTask taskId userId = do (taskRef, _ :: Task) <- getAggregateRoot taskId- publishEvent taskRef $ TaskStarred userId+ publishEvent taskRef $ TaskEvent $ TaskStarred userId return () -- Unstar a task. unstarTask :: TaskId -> UserId -> TransactionT Event IO () unstarTask taskId userId = do (taskRef, _ :: Task) <- getAggregateRoot taskId- publishEvent taskRef $ TaskUnstarred userId+ publishEvent taskRef $ TaskEvent $ TaskUnstarred userId return () -- Log work. Returns the GUID of the newly logged work.-logWork :: TaskId -> UserId -> Day -> Integer -> Text -> TransactionT Event IO WorkUnitId+logWork :: TaskId -> UserId -> Day -> Duration -> Text -> TransactionT Event IO WorkUnitId logWork taskId userId day duration comment = do -- Find the task. (taskRef, _ :: Task) <- getAggregateRoot taskId -- Publish the event to the task. wid <- lift $ newGUID- publishEvent taskRef $ RecordedWorkUnit wid day duration comment userId+ publishEvent taskRef $ TaskEvent $ RecordedWorkUnit wid day duration comment userId return wid
− src/CQRSExample/Controller/Auth.hs
@@ -1,30 +0,0 @@-module CQRSExample.Controller.Auth- ( basicAuth- ) where--import Control.Monad.Trans.Class (lift)-import qualified Data.ByteString.Char8 as B-import Data.Foldable (foldMap)-import qualified Happstack.Crypto.Base64 as Base64-import Happstack.Lite (ServerPart, Response)-import Happstack.Server.Monads (setHeaderM, getHeaderM, escape)-import Happstack.Server.Response (unauthorized, toResponse)---- | Support for Basic Auth.-basicAuth :: String -> (String -> String -> IO Bool) -> (String -> ServerPart Response) -> ServerPart Response-basicAuth realmName authMap rest = do- aHeader <- getHeaderM "authorization"- case foldMap parseHeader aHeader of- (name, ':':password) -> do- found <- lift $ authMap name password- case found of- True -> rest name- False -> err- _ -> err- where- parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6- headerName = "WWW-Authenticate"- headerValue = "Basic realm=\"" ++ realmName ++ "\""- err = escape $ do- setHeaderM headerName headerValue- unauthorized $ toResponse ("Not authorized" :: String)
+ src/CQRSExample/Duration.hs view
@@ -0,0 +1,40 @@+module CQRSExample.Duration+ ( Duration+ , hours+ , minutes+ , seconds+ , toMinutes+ , toSeconds+ ) where++import Data.SafeCopy (base, deriveSafeCopySimple)+import Data.Typeable (Typeable)++-- | Duration type.+data Duration = Duration Integer+ deriving (Typeable, Show, Eq)++-- | Create a new duration from a number of minutes.+minutes :: Integer -> Duration+minutes m = Duration (60 * m)++-- | Create a new duration from a number of seconds.+seconds :: Integer -> Duration+seconds s = Duration s++-- | Create a new duration from a number of hours.+hours :: Integer -> Duration+hours h = Duration (60 * 60 * h)++-- | Get the number of seconds from a duration.+toSeconds :: Duration -> Integer+toSeconds (Duration s) = s++-- | Get the number of minutes from a duration.+-- Any seconds are truncated.+toMinutes :: Duration -> Integer+toMinutes (Duration s) = s `div` 60++-- SafeCopy instances.++$(deriveSafeCopySimple 1 'base ''Duration)
src/CQRSExample/Events.hs view
@@ -1,96 +1,47 @@ module CQRSExample.Events ( Event(..)+ , ProjectEvent(..)+ , SiteEvent(..)+ , TaskEvent(..)+ , UserEvent(..) ) where -import Control.Monad (liftM) import CQRSExample.Aggregates+import CQRSExample.Duration (Duration) import Data.CQRS (GUID)-import Data.Serialize (Serialize(..))+import Data.SafeCopy (base, deriveSafeCopySimple) import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Typeable (Typeable)-import Data.Word (Word8) -data Event = ProjectCreated Text Text- | ProjectRenamed Text- | TaskAdded ProjectId Text- | RecordedWorkUnit GUID Day Integer Text UserId- | UserCreated Text Text Text Text- | UserRegistered Text- | TaskStarred UserId- | TaskUnstarred UserId+data Event = ProjectEvent ProjectEvent+ | TaskEvent TaskEvent+ | UserEvent UserEvent+ | SiteEvent SiteEvent deriving (Typeable, Show) -instance Serialize Event where- put (ProjectCreated name shortDesc) = do- put (0 :: Word8)- put $ encodeUtf8 name- put $ encodeUtf8 shortDesc- put (ProjectRenamed name) = do- put (1 :: Word8)- put $ encodeUtf8 name- put (TaskAdded pid tsd) = do- put (2 :: Word8)- put $ pid- put $ encodeUtf8 tsd- put (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do- put (3 :: Word8)- put $ wuId- put $ wuDay- put $ wuDuration- put $ encodeUtf8 wuComment- put wuUserId- put (UserCreated ucUserName ucPassword ucFirst ucLast) = do- put (4 :: Word8)- put $ encodeUtf8 ucUserName- put $ encodeUtf8 ucPassword -- FIXME: Should really hash the password, shouldn't we?- put $ encodeUtf8 ucFirst- put $ encodeUtf8 ucLast- put (TaskStarred userId) = do- put (5 :: Word8)- put userId- put (TaskUnstarred userId) = do- put (6 :: Word8)- put userId- put (UserRegistered userId) = do- put (7 :: Word8)- put userId- get = do- i :: Word8 <- get- case i of- 0 -> do- n <- liftM decodeUtf8 get- sd <- liftM decodeUtf8 get- return $ ProjectCreated n sd- 1 -> do- n <- liftM decodeUtf8 get- return $ ProjectRenamed n- 2 -> do- pid <- get- tsd <- liftM decodeUtf8 get- return $ TaskAdded pid tsd- 3 -> do- wuId <- get- wuDay <- get- wuDuration <- get- wuComment <- liftM decodeUtf8 get- wuUserId <- get- return $ RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId- 4 -> do- ucUserName <- liftM decodeUtf8 get- ucPassword <- liftM decodeUtf8 get- ucFirst <- liftM decodeUtf8 get- ucLast <- liftM decodeUtf8 get- return $ UserCreated ucUserName ucPassword ucFirst ucLast- 5 -> do- userId <- get- return $ TaskStarred userId- 6 -> do- userId <- get- return $ TaskUnstarred userId- 7 -> do- userId <- get- return $ UserRegistered userId- _ -> do- fail $ "Unrecognized event type " ++ show i+data ProjectEvent = ProjectCreated Text Text+ | ProjectRenamed Text+ deriving (Typeable, Show)++data TaskEvent = TaskAdded ProjectId Text Duration UserId UTCTime+ | TaskStarred UserId+ | TaskUnstarred UserId+ | RecordedWorkUnit GUID Day Duration Text UserId+ deriving (Typeable, Show)++data UserEvent = UserCreated Text Text Text Text+ deriving (Typeable, Show)++data SiteEvent = UserRegistered Text+ deriving (Typeable, Show)++-- SafeCopy instances. It is extremely important that compatibility is preserved+-- as detailed in the SafeCopy documentation.++$(deriveSafeCopySimple 1 'base ''ProjectEvent)+$(deriveSafeCopySimple 1 'base ''TaskEvent)+$(deriveSafeCopySimple 1 'base ''UserEvent)+$(deriveSafeCopySimple 1 'base ''SiteEvent)+$(deriveSafeCopySimple 1 'base ''Event)
src/CQRSExample/Instances.hs view
@@ -10,67 +10,85 @@ import qualified Data.Text as T instance Eventable Project Event where- applyEvent (ProjectCreated name shortDesc) DefaultProject =- ActiveProject name shortDesc -- Project changes to "active".- applyEvent (ProjectCreated _ _ ) (ActiveProject _ _) =- error "Invalid ProjectCreated event for project that already exists"- applyEvent (ProjectRenamed _ ) DefaultProject =- error "Cannot rename inactive project"- applyEvent (ProjectRenamed name) project@(ActiveProject _ _) =- project { projectName = name }- applyEvent (TaskAdded _ _) DefaultProject =- error "Cannot add task to inactive project"- applyEvent (TaskAdded _ _) project@(ActiveProject _ _) =- project -- Project doesn't change- applyEvent (RecordedWorkUnit _ _ _ _ _) DefaultProject =- error "Cannot record work on inactive project"- applyEvent (RecordedWorkUnit _ _ _ _ _) project@(ActiveProject _ _) =- project -- Project doesn't change- applyEvent (TaskStarred _) project =- project -- Project doesn't change- applyEvent (TaskUnstarred _) project =- project -- Project doesn't change- applyEvent (UserCreated _ _ _ _) project =++ applyEvent (ProjectEvent projectEvent) project_ =+ go projectEvent project_+ where+ go (ProjectCreated name shortDesc) UninitializedProject =+ ActiveProject name shortDesc -- Project changes to "active".+ go (ProjectCreated _ _ ) (ActiveProject _ _) =+ error "Invalid ProjectCreated event for project that already exists"+ go (ProjectRenamed _ ) UninitializedProject =+ error "Cannot rename uninitialized project"+ go (ProjectRenamed name) project@(ActiveProject _ _) =+ project { projectName = name }++ applyEvent (TaskEvent _) project = project- applyEvent (UserRegistered _) project =++ applyEvent (UserEvent _) project = project + applyEvent (SiteEvent _) project =+ project+ instance Eventable Task Event where- applyEvent (ProjectCreated _ _) task = task- applyEvent (ProjectRenamed _) task = task- applyEvent (TaskAdded pId tsd) NewTask =- ActiveTask pId tsd T.empty M.empty- applyEvent (TaskAdded _ _) (ActiveTask _ _ _ _) =- error "Cannot add task which already exists"- applyEvent (RecordedWorkUnit _ _ _ _ _) NewTask =- error "Cannot record work on inactive task"- applyEvent (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) task@(ActiveTask _ _ _ workUnits) =- task { taskWorkUnits = M.insert wuDay (WorkUnit wuId wuComment wuDuration wuUserId) workUnits }- applyEvent (UserCreated _ _ _ _) task = task- applyEvent (TaskStarred _) task = task- applyEvent (TaskUnstarred _) task = task- applyEvent (UserRegistered _) task = task + applyEvent (ProjectEvent _) task =+ task++ applyEvent (TaskEvent taskEvent) project_ =+ go taskEvent project_+ where+ go (TaskAdded pId tsd _ _ _) UninitializedTask =+ ActiveTask pId tsd T.empty M.empty+ go (TaskAdded _ _ _ _ _) (ActiveTask _ _ _ _) =+ error "Cannot add task which already exists"+ go (TaskStarred _) task = task+ go (TaskUnstarred _) task = task+ go (RecordedWorkUnit _ _ _ _ _) UninitializedTask =+ error "Cannot record work on uninitialized task"+ go (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) task@(ActiveTask _ _ _ workUnits) =+ task { taskWorkUnits = M.insert wuDay (WorkUnit wuId wuComment wuDuration wuUserId) workUnits }++ applyEvent (UserEvent _) task =+ task++ applyEvent (SiteEvent _) task =+ task+ instance Eventable User Event where- applyEvent (ProjectCreated _ _) user = user- applyEvent (ProjectRenamed _) user = user- applyEvent (TaskAdded _ _) user = user- applyEvent (RecordedWorkUnit _ _ _ _ _) user = user- applyEvent (TaskStarred _) user = user- applyEvent (TaskUnstarred _) user = user- applyEvent (UserCreated _ _ _ _) (ActiveUser _ _ _ _) =- error "User already exists"- applyEvent (UserCreated ucUserName ucPassword ucFirstName ucLastName) UncreatedUser =- ActiveUser ucUserName ucPassword ucFirstName ucLastName- applyEvent (UserRegistered _) user = user + applyEvent (ProjectEvent _) user =+ user++ applyEvent (TaskEvent _) user =+ user++ applyEvent (UserEvent userEvent) user =+ go userEvent user+ where+ go (UserCreated _ _ _ _) (ActiveUser _ _ _ _) =+ error "User already exists"+ go (UserCreated ucUserName ucPassword ucFirstName ucLastName) UninitializedUser =+ ActiveUser ucUserName ucPassword ucFirstName ucLastName++ applyEvent (SiteEvent _) user =+ user+ instance Eventable Site Event where- applyEvent (ProjectCreated _ _) site = site- applyEvent (ProjectRenamed _) site = site- applyEvent (TaskAdded _ _) site = site- applyEvent (RecordedWorkUnit _ _ _ _ _) site = site- applyEvent (TaskStarred _) site = site- applyEvent (TaskUnstarred _) site = site- applyEvent (UserCreated _ _ _ _) site = site- applyEvent (UserRegistered ucUserName) site =- site { sUserNames = S.insert ucUserName $ sUserNames site }++ applyEvent (ProjectEvent _) site =+ site++ applyEvent (TaskEvent _) site =+ site++ applyEvent (UserEvent _) site =+ site++ applyEvent (SiteEvent siteEvent) site_ =+ go siteEvent site_+ where+ go (UserRegistered ucUserName) site =+ site { sUserNames = S.insert ucUserName $ sUserNames site }
src/CQRSExample/Json.hs view
@@ -1,124 +1,58 @@ module CQRSExample.Json- ( jsonServerPart+ ( qProjectListJson+ , qTaskListJson+ , qTimesheetJson ) where -import Control.Applicative (optional)-import Control.Monad (liftM, void)-import Control.Monad.Trans.Class (lift)-import CQRSExample.Command (logWork, createProject, createTask, starTask, unstarTask)-import CQRSExample.Events (Event)-import CQRSExample.Query-import Data.Aeson (ToJSON, encode, toJSON)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.CQRS (EventStore, runTransactionT)-import Data.CQRS.GUID (GUID, hexEncode, hexDecode)+import Control.Monad (liftM)+import Data.Aeson (ToJSON, Value, toJSON)+import Data.CQRS.GUID (GUID, hexEncode) import Data.List (groupBy)+import Data.Map (Map) import qualified Data.Map as M-import Data.Maybe (fromJust)+import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE import Data.Time.Calendar (Day)-import Data.Time.Format (parseTime) import Database.HDBC (IConnection)-import Happstack.Lite-import Happstack.Server.RqData (lookRead)-import System.Locale (defaultTimeLocale) +import CQRSExample.Aggregates (UserId)+import qualified CQRSExample.Duration as D+import CQRSExample.Query+ -- Instances. instance ToJSON Day where toJSON d = toJSON $ show d --- Parse request parameter to date. Fails the request--- if the parameter is absent.-lookDay :: String -> ServerPart Day-lookDay pn = do- p <- lookText pn- case parseTime defaultTimeLocale "%F" $ TL.unpack $ p of- Just d -> return d- Nothing -> fail $ "Missing parameter '" ++ pn ++ "'"---- Retrieve a GUID parameter.-lookGUID :: String -> ServerPart (Maybe GUID)-lookGUID name = do- bs <- optional $ lookBS name- case bs of- Nothing -> return Nothing- Just bs' -> return $ hexDecode $ BS.concat $ BSL.toChunks $ bs'---- Serve JSON ok response.-okJson :: ToJSON a => a -> ServerPart Response-okJson a = ok $ toResponseBS "text/json" $ encode a---- Serve a list generated by a monadic action as a JSON response.-listJson :: (IConnection c, ToJSON b) => c -> (c -> IO [a]) -> (a -> b) -> ServerPart Response-listJson connection lister f = do- p <- liftM (map f) $ lift $ lister connection- okJson $ p---- Serve JSON project list.-projectsJson :: IConnection c => c -> EventStore Event -> ServerPart Response-projectsJson connection eventStore =- msum [ method GET >> getProjects- , method POST >> postProjects- ]- where- getProjects :: ServerPart Response- getProjects = do- (listJson connection qProjectList- (\(g,pn,psd) ->- M.fromList [ (T.pack "id" , TE.decodeUtf8 $ hexEncode g)- , (T.pack "name" , pn)- , (T.pack "short_desc", psd)- ]))- postProjects = do- pn <- fmap TL.toStrict $ lookText "name"- pd <- fmap TL.toStrict $ lookText "shortDescription"- pid <- lift $ runTransactionT eventStore $ do- createProject pn pd- ok $ toResponse $ hexEncode pid+-- Generate a list of JSONable values.+qListToJson :: (IConnection c, ToJSON b) => (c -> IO [a]) -> (a -> b) -> c -> IO [b]+qListToJson lister f conn = liftM (map f) $ lister conn --- Serve JSON task list.-tasksJson :: IConnection c => c -> EventStore Event -> String -> ServerPart Response-tasksJson connection eventStore userName =- msum [ method GET >> getTasks- , method POST >> postTasks- ]- where- getTasks :: ServerPart Response- getTasks = do- projectId <- lookGUID "projectId"- (listJson connection (qTaskList userName projectId)- (\(g,tsd,starred) ->- M.fromList [ (T.pack "id" , toJSON $ TE.decodeUtf8 $ hexEncode g)- , (T.pack "short_description", toJSON $ tsd)- , (T.pack "starred" , toJSON $ starred)- ]))+-- JSON queries.+qProjectListJson :: (IConnection c) => c -> IO [Map Text Text]+qProjectListJson =+ (qListToJson qProjectList+ (\(g,pn,psd) ->+ M.fromList [ (T.pack "id" , TE.decodeUtf8 $ hexEncode g)+ , (T.pack "name" , pn)+ , (T.pack "short_desc", psd)+ ])) - postTasks :: ServerPart Response- postTasks = do- mpid <- fmap (hexDecode . BS.concat . BSL.toChunks) $ lookBS "projectId"- case mpid of- Nothing -> fail "Invalid project ID"- Just pid -> do- tsd <- fmap TL.toStrict $ lookText "shortDescription"- tid <- lift $ runTransactionT eventStore $ do- createTask pid tsd- ok $ toResponse $ hexEncode tid+qTaskListJson :: (IConnection c) => UserId -> Maybe GUID -> c -> IO [Map Text Value]+qTaskListJson userId mProjectId =+ (qListToJson (qTaskList userId mProjectId)+ (\(g,tsd,starred) ->+ M.fromList [ (T.pack "id" , toJSON $ TE.decodeUtf8 $ hexEncode g)+ , (T.pack "short_description", toJSON $ tsd)+ , (T.pack "starred" , toJSON $ starred)+ ])) --- Serve JSON time sheet.-timeSheetJson :: IConnection c => c -> String -> ServerPart Response-timeSheetJson connection userName = do- fromDate <- lookDay "fromDate"- toDate <- lookDay "toDate"+qTimesheetJson :: (IConnection c) => Day -> Day -> UserId -> c -> IO [Map Text Value]+qTimesheetJson fromDate toDate userId connection = do -- Generate the time sheet data.- timeSheet <- lift $ qTimeSheet fromDate toDate userName connection- -- Group by tasks to make the front end manipulation a little easier.- let groupedTimeSheet =- groupBy (\(tid1,_,_,_) (tid2,_,_,_) -> (tid1==tid2)) timeSheet+ timeSheet <- fmap g $ qTimeSheet fromDate toDate userId connection -- Generate the JSON data.- okJson $ map+ return $ map (\entries -> case entries of [] -> M.fromList []@@ -128,52 +62,7 @@ , (T.pack "timeSheet", toJSON $ map (\(_,_,day,total) -> M.fromList [ (T.pack "date", toJSON $ day)- , (T.pack "total", toJSON total) ] ) entries) ])- groupedTimeSheet---- Stars server part.-starsServerPart :: IConnection c => c -> EventStore Event -> String -> ServerPart Response-starsServerPart connection eventStore userName = do- msum [ method POST >> postStars- ]+ , (T.pack "total", toJSON $ D.toMinutes total) ] ) entries) ])+ timeSheet where- postStars :: ServerPart Response- postStars = do- mTaskId <- fmap (hexDecode . BS.concat . BSL.toChunks) $ lookBS "taskId"- case mTaskId of- Nothing -> fail "Invalid task ID"- Just taskId -> do- mUserId <- lift $ qUserIdFromUserName connection (T.pack userName) -- TODO: Move this lookup to the authentication server part.- case mUserId of- Nothing -> fail "Invalid user name"- Just userId -> do- starredS <- lookBS "starred"- case starredS of- "true" -> lift $ runTransactionT eventStore $ void $ starTask taskId userId- "false" -> lift $ runTransactionT eventStore $ void $ unstarTask taskId userId- _ -> fail "Invalid input"- ok $ toResponse ("OK" :: String)---- Log work.-logWorkPost :: EventStore Event -> ServerPart Response-logWorkPost eventStore = do- -- FIXME: Avoid fromJust + lookRead! This is extremely crashy.- taskId <- liftM (fromJust . hexDecode . BS.concat . BSL.toChunks) $ lookBS "taskId"- duration <- lookRead "duration"- comment <- lookText "comment"- date <- lookDay "date"- let userId = fromJust $ hexDecode "" -- FIXME: Use USER ID of authenticated user!- lift $ runTransactionT eventStore $ do- void $ logWork taskId userId date duration (TL.toStrict comment)- ok $ toResponse ("" :: String)---- Serve JSON data.-jsonServerPart :: IConnection c => c -> EventStore Event -> String -> ServerPart Response-jsonServerPart conn eventStore userName =- msum- [ dir "projects" $ projectsJson conn eventStore- , dir "tasks" $ tasksJson conn eventStore userName- , dir "stars" $ starsServerPart conn eventStore userName- , dir "time-sheet" $ timeSheetJson conn userName- , dir "do-log-work" $ logWorkPost eventStore- ]+ g = groupBy (\(tid1,_,_,_) (tid2,_,_,_) -> (tid1==tid2))
src/CQRSExample/Main.hs view
@@ -1,70 +1,85 @@+import Blaze.ByteString.Builder (Builder)+import Blaze.ByteString.Builder.Char8 (fromText) import Control.Concurrent (forkIO, threadDelay)-import Control.Monad (void, liftM)+import Control.Concurrent.Chan (Chan, newChan, writeList2Chan)+import Control.Monad (void) import Data.CQRS import Data.CQRS.EventStore.Backend.Sqlite3 (openSqliteEventStore)-import Data.Foldable (foldMap)+import qualified Data.Set as S+import Data.Text (Text) import qualified Data.Text as T import Database.HDBC (IConnection) import Database.HDBC.Sqlite3 (connectSqlite3)-import Happstack.Lite-import CQRSExample.Command (siteInitialization)-import CQRSExample.Controller.Auth+import Network.Wai.EventSource (ServerEvent(..))+import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)+import Prelude hiding (mapM)++import CQRSExample.Command import CQRSExample.Events import CQRSExample.Instances ()-import CQRSExample.Json (jsonServerPart) import CQRSExample.Query--sqliteFile :: String-sqliteFile = "example.db"+import CQRSExample.Wai+import CQRSExample.WaiAuth -eventSourcingThread :: IConnection c => c -> EventStore Event -> IO ()-eventSourcingThread connection eventStore = do+-- Source of refresh events to the browser.+eventSourcingThread :: IConnection c => c -> Chan ServerEvent -> EventStore Event -> IO ()+eventSourcingThread connection jsonEvents eventStore = do loop where loop = do putStrLn "Sourcing events..."- reactToUnseenEvents connection eventStore+ refresh <- reactToUnseenEvents connection eventStore+ -- Issue refresh events to browser.+ writeList2Chan jsonEvents (map (toServerEvent . fromText . convertRefresh) $ S.toList refresh) -- Wait 1 second threadDelay 1000000 -- Go again. loop+ -- Convert refresh values to JSON for browser.+ convertRefresh :: Refresh -> Text+ convertRefresh RefreshProjects = "refresh-projects"+ convertRefresh RefreshTasks = "refresh-tasks"+ convertRefresh RefreshTimesheet = "refresh-timesheet"+ -- Convert a value to a server event.+ toServerEvent :: Builder -> ServerEvent+ toServerEvent j = ServerEvent Nothing Nothing [j] -- Check user.-checkUser :: IConnection c => c -> String -> String -> IO Bool+checkUser :: IConnection c => c -> String -> String -> IO (Maybe AuthenticatedUser) checkUser c u p = do- p' <- liftM (foldMap T.unpack) $ qFindUserPassword c (T.pack u)- return $ (==) p p'---- Serve.-myApp :: IConnection c => c -> EventStore Event -> ServerPart Response-myApp conn eventStore = msum- [ dir "js" $ serveDirectory EnableBrowsing [ ] "static/js"- , dir "css" $ serveDirectory EnableBrowsing [ ] "static/css"- , dir "json" $ basicAuth "Restricted Area" (checkUser conn) $ jsonServerPart conn eventStore- , serveDirectory EnableBrowsing [ "index.html" ] "static"- ]+ user <- qFindUser c $ T.pack u+ case user of+ Just (userId, p') ->+ return $ if p == T.unpack p' then Just (AuthenticatedUser u userId) else Nothing+ Nothing ->+ return Nothing ----test1 :: IO ()-test1 =+-- Start serving the application.+startServing :: IO ()+startServing = do let queryDbFile = "query.db"+ let sqliteFile = "example.db" -- Connect to query database conn <- connectSqlite3 queryDbFile setupQueryDatabase conn -- Perform any necessary setup. - -- TODO: Should really do a "disconnect" too.+ -- Queue of json events to send to browser.+ jsonEvents <- newChan -- Start sourcing events. _ <- forkIO $ do withEventStore (openSqliteEventStore sqliteFile) $ do- eventSourcingThread conn+ eventSourcingThread conn jsonEvents -- Web serving thread.+ let mySettings = defaultSettings { settingsPort = 8000 } void $ forkIO $ do withEventStore (openSqliteEventStore sqliteFile) $ \eventStore ->- serve Nothing $ myApp conn eventStore+ runSettings mySettings $+ basicAuth "Clockwork" (checkUser conn) $+ exampleWaiApplication conn eventStore jsonEvents -- Perform site initialization if necessary. withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> do@@ -73,8 +88,8 @@ main :: IO () main = do- putStrLn "Running test1..."- test1+ putStrLn "Starting..."+ startServing putStrLn "Press <Enter> to quit" _ <- getLine return ()
src/CQRSExample/Query.hs view
@@ -1,27 +1,48 @@ module CQRSExample.Query- ( setupQueryDatabase- , qFindUserPassword+ ( Refresh(..)+ , setupQueryDatabase+ , qFindUser , qProjectList , qTaskList , qTimeSheet- , qUserIdFromUserName , reactToUnseenEvents ) where import Control.Monad (liftM, void)-import CQRSExample.Aggregates (UserId)-import CQRSExample.Events (Event(..))+import qualified Data.ByteString.Char8 as BS8+import Data.Conduit (runResourceT, ($$))+import qualified Data.Conduit.List as CL import Data.Convertible (Convertible(..), convError) import Data.CQRS (enumerateEventStore, GUID, EventStore) import qualified Data.CQRS.GUID as G import Data.CQRS.PersistedEvent (PersistedEvent(..))-import Data.Enumerator (run_, (>>==))-import qualified Data.Enumerator.List as EL import Data.Foldable (forM_)+import Data.Set (Set)+import qualified Data.Set as S import Data.Text (Text) import Data.Time.Calendar (Day) import Database.HDBC (IConnection, SqlValue(..), fromSql, quickQuery', run, runRaw, toSql, withTransaction) +import CQRSExample.Aggregates (UserId)+import CQRSExample.Duration (Duration)+import qualified CQRSExample.Duration as D+import CQRSExample.Events (Event(..), ProjectEvent(..), TaskEvent(..), UserEvent(..), SiteEvent(..))++-- Refresh event.+data Refresh = RefreshTasks+ | RefreshProjects+ | RefreshTimesheet+ deriving (Show, Eq, Ord)++-- Conversion between Duration and SQLValue.+instance Convertible Duration SqlValue where+ safeConvert duration = Right $ toSql $ D.toSeconds duration++instance Convertible SqlValue Duration where+ safeConvert (SqlInteger i) = Right $ D.seconds i+ safeConvert (SqlByteString s) = Right $ D.seconds $ read $ BS8.unpack s+ safeConvert a = convError "Invalid source value" a+ -- Conversion between GUID and SQLValue. instance Convertible GUID SqlValue where safeConvert g = Right $ toSql $ G.toByteString g@@ -46,17 +67,17 @@ setupQueryDatabase c = do runRaw c "CREATE TABLE IF NOT EXISTS gversion ( gversion INTEGER )" runRaw c "CREATE TABLE IF NOT EXISTS projects ( guid BLOB , name TEXT , short_desc TEXT )"- runRaw c "CREATE TABLE IF NOT EXISTS tasks ( guid BLOB , project_guid BLOB , short_desc TEXT , long_desc TEXT )"+ runRaw c "CREATE TABLE IF NOT EXISTS tasks ( guid BLOB , project_guid BLOB , short_desc TEXT , long_desc TEXT , estimate INTEGER , user_guid BLOB , created_ts TEXT )" runRaw c "CREATE TABLE IF NOT EXISTS users ( user_id BLOB , user_name TEXT , user_pass TEXT , first_name TEXT , last_name TEXT )" runRaw c "CREATE TABLE IF NOT EXISTS work_units ( task_guid BLOB , wu_guid BLOB , wu_date TEXT , wu_duration INTEGER , wu_comment TEXT , user_id BLOB )"- runRaw c "CREATE TABLE IF NOT EXISTS tasks_starred_by ( task_id BLOB, user_id BLOB , user_name TEXT )"+ runRaw c "CREATE TABLE IF NOT EXISTS tasks_starred_by ( task_id BLOB, user_id BLOB )" -- Find user password from database.-qFindUserPassword :: IConnection c => c -> Text -> IO (Maybe Text)-qFindUserPassword c userName = fmap extract1 $ smq c "SELECT user_pass FROM users WHERE user_name = ?" [ toSql userName ] convert+qFindUser :: IConnection c => c -> Text -> IO (Maybe (GUID, Text))+qFindUser c userName = fmap extract1 $ smq c "SELECT U.user_id, U.user_pass FROM users U WHERE U.user_name = ?" [ toSql userName ] convert where- convert :: [SqlValue] -> Text- convert [p] = fromSql p+ convert :: [SqlValue] -> (GUID, Text)+ convert [uid, p] = (fromSql uid, fromSql p) convert _ = error "Invalid number of columns in SQL query result" -- Query project list@@ -68,13 +89,13 @@ convert _ = error "Invalid number of columns in SQL query result" -- Query task list-qTaskList :: IConnection c => String -> Maybe GUID -> c -> IO [(GUID, Text, Bool)]-qTaskList userName mProjectId c =+qTaskList :: IConnection c => UserId -> Maybe GUID -> c -> IO [(GUID, Text, Bool)]+qTaskList userId mProjectId c = case mProjectId of Nothing ->- smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_name = ? OR TS.user_name IS NULL)" [ toSql userName ] convert+ smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_id = ? OR TS.user_id IS NULL)" [ toSql userId ] convert Just projectId ->- smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_name = ? OR TS.user_name IS NULL) AND T.project_guid = ?" [ toSql userName, toSql projectId ] convert+ smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_id = ? OR TS.user_id IS NULL) AND T.project_guid = ?" [ toSql userId, toSql projectId ] convert where convert :: [SqlValue] -> (GUID,Text,Bool) convert [ guid, short_desc, starred_by_user ] =@@ -88,48 +109,32 @@ -- Query work units in a date interval. The result is a list of tasks -- (IDs, short description), with daily totals (in minutes) for each task.-qTimeSheet :: IConnection c => Day -> Day -> String -> c -> IO [(GUID, Text, Maybe Day, Int)]-qTimeSheet startDate endDate userName c =- (smq c "SELECT T.guid, W.wu_date, T.short_desc, COALESCE(SUM(W.wu_duration),0) FROM tasks T LEFT OUTER JOIN work_units W ON W.task_guid=T.guid LEFT OUTER JOIN tasks_starred_by ST ON ST.task_id=T.guid WHERE ((W.wu_duration IS NOT NULL) AND (W.wu_date>=? AND W.wu_date<?)) OR (ST.user_name = ?) GROUP BY T.guid, W.wu_date"+qTimeSheet :: IConnection c => Day -> Day -> UserId -> c -> IO [(GUID, Text, Maybe Day, Duration)]+qTimeSheet startDate endDate userId c =+ (smq c "SELECT T.guid, W.wu_date, T.short_desc, COALESCE(SUM(W.wu_duration),0) FROM tasks T LEFT OUTER JOIN work_units W ON W.task_guid=T.guid LEFT OUTER JOIN tasks_starred_by ST ON ST.task_id=T.guid WHERE ((W.wu_duration IS NOT NULL) AND (W.wu_date>=? AND W.wu_date<?)) OR (ST.user_id = ?) GROUP BY T.guid, W.wu_date" [ toSql $ show startDate , toSql $ show endDate- , toSql userName ] convert)+ , toSql userId ] convert) where- convert :: [SqlValue] -> (GUID, Text, Maybe Day, Int)+ convert :: [SqlValue] -> (GUID, Text, Maybe Day, Duration) convert [ taskId, day, taskShortDesc, total ] = (fromSql taskId, fromSql taskShortDesc, fromSql day, fromSql total) convert _ = error "Invalid columns in SQL query result" --- Get user name for a given user ID.-qUserNameFromUserId :: IConnection c => c -> GUID -> IO (Maybe Text)-qUserNameFromUserId c userId = fmap extract1 $ smq c "SELECT U.user_name FROM users U WHERE U.user_id = ?" [ toSql userId ] convert- where- convert :: [SqlValue] -> Text- convert [u] = fromSql u- convert _ = error "Invalid columns in SQL query result"---- Get user ID from user name.-qUserIdFromUserName :: IConnection c => c -> Text -> IO (Maybe GUID)-qUserIdFromUserName c userName = fmap extract1 $ smq c "SELECT U.user_id FROM users U WHERE U.user_name = ?" [ toSql $ userName ] convert- where- convert :: [SqlValue] -> GUID- convert [u] = fromSql u- convert _ = error "Invalid columns in SQL query result"- -- Event sourcing.-reactToUnseenEvents :: IConnection c => c -> EventStore Event -> IO ()+reactToUnseenEvents :: IConnection c => c -> EventStore Event -> IO (Set Refresh) reactToUnseenEvents connection eventStore = withTransaction connection $ \_ -> do -- Find the version number to start at. startVersion <- getStartVersion -- Enumerate all the events form the event store since last run.- evs <- run_ (EL.consume >>== enumerateEventStore eventStore startVersion)+ evs <- runResourceT $ enumerateEventStore eventStore startVersion $$ CL.consume -- React to all the events. forM_ evs $ reactToEvent connection -- Update the global version number. updateStartVersion $ startVersion + length evs -- Done.- return ()+ return $ S.fromList $ calculateRefresh $ evs where getStartVersion :: IO Int@@ -145,6 +150,19 @@ _ <- run connection "INSERT INTO gversion (gversion) VALUES (?);" [ toSql newStartVersion ] return () +calculateRefresh :: [PersistedEvent Event] -> [Refresh]+calculateRefresh pes = concat $ map (f . peEvent) pes+ where+ f (ProjectEvent _) = [RefreshProjects]+ f (TaskEvent te) = fte te+ f (UserEvent _) = []+ f (SiteEvent _) = []++ fte (TaskAdded _ _ _ _ _) = [RefreshTasks]+ fte (TaskStarred _) = [RefreshTasks, RefreshTimesheet]+ fte (TaskUnstarred _) = [RefreshTasks, RefreshTimesheet]+ fte (RecordedWorkUnit _ _ _ _ _) = [RefreshTimesheet]+ reactToEvent :: IConnection c => c -> PersistedEvent Event -> IO () reactToEvent connection ev = do let gv = peGlobalVer ev@@ -154,26 +172,42 @@ where g = peAggregateGUID ev - react (ProjectCreated pn psd) = do+ reactProject (ProjectCreated pn psd) = do go "INSERT INTO projects ( guid , name , short_desc ) VALUES ( ? , ? , ? );" [ toSql g , toSql pn , toSql psd ] - react (ProjectRenamed pn) = do+ reactProject (ProjectRenamed pn) = do go "UPDATE projects SET name = ? WHERE guid = ?;" [ toSql pn , toSql g ] - react (TaskAdded pid tsd) = do- go "INSERT INTO tasks ( guid , project_guid , short_desc ) VALUES (?, ?, ?);"+ reactTask (TaskAdded pid tsd est uid ts) = do+ go "INSERT INTO tasks ( guid , project_guid , short_desc , estimate , user_guid , created_ts) VALUES (?, ?, ?, ? , ?, ?);" [ toSql g , toSql pid- , toSql tsd ]+ , toSql tsd+ , toSql est+ , toSql uid+ , toSql ts+ ] - react (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do+ reactTask (TaskStarred userId) = do+ go "INSERT INTO tasks_starred_by ( task_id , user_id ) VALUES (?, ?);"+ [ toSql g+ , toSql userId+ ]++ reactTask (TaskUnstarred userId) = do+ go "DELETE FROM tasks_starred_by WHERE task_id = ? AND user_id = ?;"+ [ toSql g+ , toSql userId+ ]++ reactTask (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do go "INSERT INTO work_units ( task_guid , wu_guid , wu_date , wu_duration , wu_comment , user_id ) VALUES ( ? , ? , ? , ? , ? , ? );" [ toSql g , toSql wuId@@ -183,7 +217,7 @@ , toSql wuUserId ] - react (UserCreated ucUserName ucPassword ucFirstName ucLastName) = do+ reactUser (UserCreated ucUserName ucPassword ucFirstName ucLastName) = do go "INSERT INTO users ( user_id , user_name , user_pass, first_name , last_name ) VALUES ( ? , ? , ? , ? , ? );" [ toSql g , toSql ucUserName@@ -192,23 +226,13 @@ , toSql ucLastName ] - react (TaskStarred userId) = do- mUserName <- qUserNameFromUserId connection userId- forM_ mUserName $ \userName -> do- go "INSERT INTO tasks_starred_by ( task_id , user_id , user_name ) VALUES (?, ?, ?);"- [ toSql g- , toSql userId- , toSql $ userName- ]-- react (TaskUnstarred userId) = do- go "DELETE FROM tasks_starred_by WHERE task_id = ? AND user_id = ?;"- [ toSql g- , toSql userId- ]-- react (UserRegistered _) = do+ reactSite (UserRegistered _) = return () -- No need to record++ react (ProjectEvent p) = reactProject p+ react (TaskEvent e) = reactTask e+ react (UserEvent e) = reactUser e+ react (SiteEvent e) = reactSite e go :: String -> [SqlValue] -> IO () go sql parameters = void $ run connection sql parameters
+ src/CQRSExample/Wai.hs view
@@ -0,0 +1,108 @@+module CQRSExample.Wai+ ( AuthenticatedUser(..)+ , exampleWaiApplication+ ) where++import Control.Concurrent.Chan (Chan)+import Control.Monad (void)+import Control.Monad.Trans.Class (lift)+import Data.Aeson (ToJSON(..), encode)+import Data.CQRS+import Data.CQRS.GUID (hexEncode)+import Data.Text (Text)+import Database.HDBC (IConnection)+import Network.HTTP.Types (status200, status404, status400, status501, StdMethod(..), parseMethod)+import Network.Wai (Application, Request, Response, pathInfo, responseLBS, requestMethod)+import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)+import Network.Wai.EventSource (eventSourceApp, ServerEvent(..))+import Prelude hiding (mapM)++import CQRSExample.Aggregates (UserId)+import CQRSExample.Command+import CQRSExample.Events+import CQRSExample.Instances ()+import CQRSExample.Json+import CQRSExample.WaiParameters++data AuthenticatedUser = -- TODO: This doesn't really belong here.+ AuthenticatedUser { auUserName :: String+ , auUserId :: UserId+ }++exampleWaiApplication :: IConnection c => c -> EventStore Event -> Chan ServerEvent -> AuthenticatedUser -> Application+exampleWaiApplication conn eventStore serverEvents user req =+ case parseMethod (requestMethod req) of+ Right method -> route method+ Left _ -> return $ responseLBS status501 [] ""++ where++ userId = auUserId user++ route method = do+ case (method,pathInfo req) of+ (GET , "events" : _) -> eventSourceApp serverEvents req+ (_ , "json" : "projects" : _) -> runParameters (appJsonProjects method) req+ (_ , "json" : "tasks" : _) -> runParameters (appJsonTasks method) req+ (_ , "json" : "time-sheet" : _) -> runParameters (appJsonTimesheet method) req+ (_ , "json" : "stars" : _) -> runParameters (appStars method) req+ (GET , _) -> staticApp defaultFileServerSettings req+ _ -> return notFound++ -- Projects+ appJsonProjects GET =+ lift $ lift $ qProjectListJson conn >>= returnJson+ appJsonProjects POST = do+ pn <- requireText "name"+ pd <- requireText "shortDescription"+ pid <- lift $ lift $ runTransactionT eventStore $ do+ createProject pn pd+ returnJson $ hexEncode pid+ appJsonProjects _ = badRequest++ -- Tasks+ appJsonTasks GET = do+ mProjectId <- lookGUID "projectId"+ lift $ lift $ qTaskListJson userId mProjectId conn >>= returnJson+ appJsonTasks POST = do+ pid <- requireGUID "projectId"+ estimate <- requireDuration "estimate"+ tsd <- requireText "shortDescription"+ tid <- lift $ lift $ runTransactionT eventStore $ do+ createTask pid tsd estimate userId+ returnJson $ hexEncode tid+ appJsonTasks _ = badRequest++ -- Timesheet+ appJsonTimesheet GET = do+ fromDate <- requireDay "fromDate"+ toDate <- requireDay "toDate"+ lift $ lift $ qTimesheetJson fromDate toDate userId conn >>= returnJson+ appJsonTimesheet POST = do+ taskId <- requireGUID "taskId"+ duration <- requireDuration "duration"+ comment <- requireText "comment"+ date <- requireDay "date"+ lift $ lift $ runTransactionT eventStore $ do+ void $ logWork taskId userId date duration comment+ returnJson ("OK" :: Text)+ appJsonTimesheet _ = badRequest++ -- Stars+ appStars POST = do+ taskId <- requireGUID "taskId"+ starred <- requireBool "starred"+ lift $ lift $ runTransactionT eventStore $ void $ do+ case starred of+ True -> starTask taskId userId+ False -> unstarTask taskId userId+ returnJson ("OK" :: Text)+ appStars _ = badRequest++ badRequest = return $ responseLBS status400 [] ""++returnJson :: Monad m => ToJSON a => a -> m Response+returnJson a = return $ responseLBS status200 [("Content-Type", "text/json")] $ encode a++notFound :: Response+notFound = responseLBS status404 [("Content-Type", "text/plain")] "404 - Not Found"
+ src/CQRSExample/WaiAuth.hs view
@@ -0,0 +1,38 @@+module CQRSExample.WaiAuth+ ( basicAuth+ ) where++import Control.Monad.Trans.Class (lift)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Base64 as B64+import Data.Foldable (foldMap)+import Network.HTTP.Types (status401)+import Network.Wai (Application, Request, Response, responseLBS, requestHeaders)++-- | Support for Basic Auth.+basicAuth :: String -> (String -> String -> IO (Maybe a)) -> (a -> Application) -> Application+basicAuth realmName authMap app req = do+ let aHeader = lookup "authorization" $ requestHeaders req+ case foldMap parseHeader aHeader of+ (name, ':':password) -> do+ found <- lift $ authMap name password+ case found of+ Just a -> app a req+ Nothing -> err+ _ -> err+ where+ -- TODO: Redo this hack.+ parseHeader = break (':'==) . f . B64.decode . B.drop 6+ f (Left _) = "error"+ f (Right s) = B8.unpack s+ err = return $ unauthorized realmName++-- Generate an "unauthorized" response.+unauthorized :: String -> Response+unauthorized realmName =+ responseLBS status401+ [ ("Content-Type", "text/plain")+ , ("WWW-Authenticate", B8.pack $ "Basic realm=\"" ++ realmName ++ "\"")+ ]+ "Not authorized"
+ src/CQRSExample/WaiParameters.hs view
@@ -0,0 +1,96 @@+module CQRSExample.WaiParameters+ ( runParameters+ , lookGUID+ , requireBool+ , requireDay+ , requireDuration+ , requireGUID+ , requireText+ ) where++import Control.Applicative ((<*>))+import Control.Monad (liftM)+import Control.Monad.Trans.Resource (ResourceT)+import Control.Monad.Trans.Reader (ask, ReaderT, runReaderT)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import Data.Conduit (($$))+import Data.CQRS+import Data.CQRS.GUID (hexDecode)+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Data.Time (Day)+import Data.Time.Format (parseTime)+import Network.HTTP.Types (Query)+import Network.Wai (Application, Request, Response, queryString, requestBody)+import Network.Wai.Parse (lbsSink, parseRequestBody, Param)+import Prelude hiding (mapM)+import System.Locale (defaultTimeLocale)++import CQRSExample.Duration (Duration)+import qualified CQRSExample.Duration as D++-- Type of the monad.+type ParametersT = ReaderT ([Param], Query)++runParameters :: ParametersT (ResourceT IO) Response -> Application+runParameters r req = do+ -- TODO: Impose a max body length.+ (params, _) <- requestBody req $$ parseRequestBody lbsSink req+ runReaderT r (params, queryString req)++look :: Monad m => ByteString -> ParametersT m (Maybe ByteString)+look n = do+ (ps, qs) <- ask+ let mq = lookup n qs+ let mp = lookup n ps+ return $ maybe mp id mq++required :: Monad m => ByteString -> ParametersT m (Maybe a) -> ParametersT m a+required n = flip (>>=) require+ where+ require (Just a) = return a+ require Nothing = fail $ "Missing/invalid parameter '" ++ (B8.unpack n) ++ "'"++lookText :: Monad m => ByteString -> ParametersT m (Maybe Text)+lookText n = liftM (maybe Nothing decode) $ look n+ where decode = either (const Nothing) Just . TE.decodeUtf8'++requireText :: Monad m => ByteString -> ParametersT m Text+requireText = required <*> lookText++lookGUID :: Monad m => ByteString -> ParametersT m (Maybe GUID)+lookGUID n = liftM (maybe Nothing hexDecode) $ look n++requireGUID :: Monad m => ByteString -> ParametersT m GUID+requireGUID = required <*> lookGUID++lookInteger :: Monad m => ByteString -> ParametersT m (Maybe Integer)+lookInteger n = liftM (maybe Nothing (f . B8.readInteger)) $ look n+ where+ f (Just (x, "")) = Just x+ f _ = Nothing++requiredInteger :: Monad m => ByteString -> ParametersT m Integer+requiredInteger = required <*> lookInteger++requireDuration :: Monad m => ByteString -> ParametersT m Duration+requireDuration n = liftM D.minutes $ requiredInteger n++lookDay :: Monad m => ByteString -> ParametersT m (Maybe Day)+lookDay n = liftM (maybe Nothing parseDay) $ look n+ where parseDay = parseTime defaultTimeLocale "%F" . B8.unpack++requireDay :: Monad m => ByteString -> ParametersT m Day+requireDay = required <*> lookDay++lookBool :: Monad m => ByteString -> ParametersT m (Maybe Bool)+lookBool n = liftM f $ look n+ where+ f (Just "true") = Just True+ f (Just "false") = Just False+ f _ = Nothing++requireBool :: Monad m => ByteString -> ParametersT m Bool+requireBool = required <*> lookBool+