cqrs-example 0.6.0 → 0.7.0
raw patch · 13 files changed
+990/−510 lines, 13 filesdep +HDBCdep +HDBC-sqlite3dep +convertibledep ~cqrsdep ~cqrs-sqlite3
Dependencies added: HDBC, HDBC-sqlite3, convertible, happstack-server, happstack-util, old-locale
Dependency ranges changed: cqrs, cqrs-sqlite3
Files
- cqrs-example.cabal +20/−10
- src/Aggregates.hs +0/−173
- src/CQRSExample/Aggregates.hs +207/−0
- src/CQRSExample/Command.hs +88/−0
- src/CQRSExample/Controller/Auth.hs +30/−0
- src/CQRSExample/Events.hs +96/−0
- src/CQRSExample/Instances.hs +76/−0
- src/CQRSExample/Json.hs +179/−0
- src/CQRSExample/Main.hs +80/−0
- src/CQRSExample/Query.hs +214/−0
- src/Events.hs +0/−74
- src/Main.hs +0/−130
- src/Query.hs +0/−123
cqrs-example.cabal view
@@ -1,5 +1,5 @@ Name: cqrs-example-Version: 0.6.0+Version: 0.7.0 Synopsis: Example for cqrs package Description: Example for cqrs package License: MIT@@ -11,19 +11,24 @@ Cabal-version: >=1.10 Executable cqrs-example- Main-is: Main.hs+ Main-is: CQRSExample/Main.hs Ghc-options: -Wall Build-depends: base == 4.* , aeson >= 0.3.2.12 && <0.4 , bytestring >= 0.9 && < 0.10 , cereal >= 0.3 && < 0.4 , containers >= 0.4 && < 0.5- , cqrs >= 0.6 && < 0.7- , cqrs-sqlite3 >= 0.6 && < 0.7+ , convertible >= 1.0.11.0 && < 1.1+ , cqrs >= 0.6.1 && < 0.7+ , cqrs-sqlite3 >= 0.6.1 && < 0.7 , data-default >= 0.3 && < 0.4- , direct-sqlite >= 1.1 && < 1.2 , 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+ , old-locale >= 1.0 && < 1.1 , text >= 0.11 && < 0.12 , time >= 1.2 && < 1.3 , transformers >= 0.2.2 && < 0.3@@ -32,20 +37,25 @@ OverloadedStrings ScopedTypeVariables Hs-source-dirs: src- Other-modules: Aggregates- Events- Query+ Other-modules: CQRSExample.Aggregates+ CQRSExample.Command+ CQRSExample.Controller.Auth+ CQRSExample.Events+ CQRSExample.Instances+ CQRSExample.Json+ CQRSExample.Query Default-language: Haskell2010 Test-Suite cqrs-example-tests type: exitcode-stdio-1.0 hs-source-dirs: src- main-is: Test.hs+ main-is: CQRSExample/Test.hs build-depends: base == 4.* , bytestring >= 0.9 && < 0.10 , cereal >= 0.3 && < 0.4 , containers >= 0.4 && < 0.5- , cqrs >= 0.5 && < 0.6+ , cqrs >= 0.6 && < 0.7+ , cqrs-sqlite3 >= 0.6 && < 0.7 , data-default >= 0.3 && < 0.4 , direct-sqlite >= 1.1 && < 1.2 , enumerator >= 0.4.15 && < 0.5
− src/Aggregates.hs
@@ -1,173 +0,0 @@-module Aggregates- ( Project(..)- , ProjectId- , Task(..)- , TaskId- , User(..)- , UserId- , WorkUnit(..)- ) where--import Control.Monad (liftM)-import Data.CQRS (Aggregate(..), GUID)-import Data.Default (Default(..))-import Data.Map (Map)-import Data.Serialize (Serialize(..), decode, encode)-import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Time.Calendar(Day(..), toGregorian, fromGregorian)-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---- Projects.--type ProjectId = GUID--data Project = DefaultProject- | 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 s =- case decode s of- Left e -> error e- Right a -> a--instance Default Project where- def = DefaultProject---- Tasks.--type TaskId = GUID--data Task = NewTask- | ActiveTask { taskProjectId :: ProjectId- , taskShortDescription :: Text- , taskLongDescription :: Text- , taskWorkUnits :: Map Day WorkUnit- }- 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 s =- case decode s of- Left e -> error e- Right a -> a--instance Default Task where- def = NewTask---- Users.--type UserId = GUID--data User = UncreatedUser- | ActiveUser { auUserName :: Text- , auLastName :: Text- , auFirstName :: Text- }- deriving (Typeable, Eq, Show)--instance Serialize User where- put UncreatedUser = do- put $ (0 :: Word8)- put (ActiveUser auun auln aufn) = do- put $ (1 :: Word8)- put $ encodeUtf8 auun- put $ encodeUtf8 auln- put $ encodeUtf8 aufn- get = do- i :: Word8 <- get- case i of- 0 -> return UncreatedUser- 1 -> do- auun <- liftM decodeUtf8 get- auln <- liftM decodeUtf8 get- aufn <- liftM decodeUtf8 get- return $ ActiveUser auun auln aufn- _ ->- fail $ "Cannot decode user state: " ++ show i--instance Aggregate User where- encodeAggregate = encode- decodeAggregate s =- case decode s of- Left e -> error e- Right a -> a--instance Default User where- def = UncreatedUser----- Work Units (NOT aggregates!)-data WorkUnit = WorkUnit { workUnitId :: GUID- , workUnitComment :: Text- , workUnitDuration :: Integer- , 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
+ src/CQRSExample/Aggregates.hs view
@@ -0,0 +1,207 @@+module CQRSExample.Aggregates+ ( Project(..)+ , ProjectId+ , Site(..)+ , siteGUID+ , Task(..)+ , TaskId+ , User(..)+ , UserId+ , WorkUnit(..)+ , WorkUnitId+ ) where++import Control.Monad (liftM)+import Data.CQRS (Aggregate(..), GUID)+import Data.CQRS.Serialize (decode')+import Data.Default (Default(..))+import Data.Map (Map)+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.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.+--+-- Note that only data required for command verification is necessary+-- here!+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'++instance Default Site where+ def = Site S.empty++-- GUID for the single Site aggregate.+siteGUID :: GUID+siteGUID = def++-- Projects.++type ProjectId = GUID++data Project = DefaultProject+ | 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++-- Tasks.++type TaskId = GUID++data Task = NewTask+ | ActiveTask { taskProjectId :: ProjectId+ , taskShortDescription :: Text+ , taskLongDescription :: Text+ , taskWorkUnits :: Map Day WorkUnit+ }+ 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++-- Users.++type UserId = GUID++data User = UncreatedUser+ | ActiveUser { auUserName :: Text+ , auPassword :: Text+ , auLastName :: Text+ , auFirstName :: Text+ }+ 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+++-- Work Units (NOT aggregates!)+type WorkUnitId = GUID++data WorkUnit = WorkUnit { workUnitId :: GUID+ , workUnitComment :: Text+ , workUnitDuration :: Integer+ , 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
+ src/CQRSExample/Command.hs view
@@ -0,0 +1,88 @@+module CQRSExample.Command+ ( createProject+ , createTask+ , createUser+ , logWork+ , renameProject+ , siteInitialization+ , starTask+ , unstarTask+ ) where++import Control.Monad (when, void)+import Control.Monad.Trans.Class (lift)+import CQRSExample.Aggregates+import CQRSExample.Events+import CQRSExample.Instances ()+import Data.CQRS+import qualified Data.Set as S+import Data.Text (Text)+import Data.Time.Calendar (Day)++-- Perform any needed site initialization.+siteInitialization :: TransactionT Event IO ()+siteInitialization = do+ (_, site :: Site) <- getAggregateRoot siteGUID+ -- If there are no users, we'll create a default "admin" user.+ when (S.null $ sUserNames site) $ do+ void $ createUser "admin" "admin" "Administrator" ""++-- Create a new user.+createUser :: Text -> Text -> Text -> Text -> TransactionT Event IO UserId+createUser userName password lastName firstName = do+ -- Check for duplicate user names.+ (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+ -- Publish to the user aggregate.+ userId <- lift $ newGUID+ (userRef, _ :: User) <- getAggregateRoot userId+ publishEvent userRef $ UserCreated userName password firstName lastName+ return userId++-- Create a new project.+createProject :: Text -> Text -> TransactionT Event IO ProjectId+createProject name shortDescription = do+ projectId <- lift $ newGUID+ (projectRef, _ :: Project) <- getAggregateRoot projectId+ publishEvent projectRef $ 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++-- Create new task in a project.+createTask :: ProjectId -> Text -> TransactionT Event IO TaskId+createTask projectId shortDescription = do+ taskId <- lift $ newGUID+ (taskRef, _ :: Task) <- getAggregateRoot taskId+ publishEvent taskRef $ TaskAdded projectId shortDescription+ return taskId++-- Star a task.+starTask :: TaskId -> UserId -> TransactionT Event IO ()+starTask taskId userId = do+ (taskRef, _ :: Task) <- getAggregateRoot taskId+ publishEvent taskRef $ TaskStarred userId+ return ()++-- Unstar a task.+unstarTask :: TaskId -> UserId -> TransactionT Event IO ()+unstarTask taskId userId = do+ (taskRef, _ :: Task) <- getAggregateRoot taskId+ publishEvent taskRef $ 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 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+ return wid
+ src/CQRSExample/Controller/Auth.hs view
@@ -0,0 +1,30 @@+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/Events.hs view
@@ -0,0 +1,96 @@+module CQRSExample.Events+ ( Event(..)+ ) where++import Control.Monad (liftM)+import CQRSExample.Aggregates+import Data.CQRS (GUID)+import Data.Serialize (Serialize(..))+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+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+ 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
+ src/CQRSExample/Instances.hs view
@@ -0,0 +1,76 @@+module CQRSExample.Instances+ (+ ) where++import CQRSExample.Aggregates+import CQRSExample.Events+import Data.CQRS (Eventable(..))+import qualified Data.Map as M+import qualified Data.Set as S+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 =+ project+ applyEvent (UserRegistered _) 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++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++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 }
+ src/CQRSExample/Json.hs view
@@ -0,0 +1,179 @@+module CQRSExample.Json+ ( jsonServerPart+ ) 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 Data.List (groupBy)+import qualified Data.Map as M+import Data.Maybe (fromJust)+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)++-- 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++-- 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)+ ]))++ 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++-- Serve JSON time sheet.+timeSheetJson :: IConnection c => c -> String -> ServerPart Response+timeSheetJson connection userName = do+ fromDate <- lookDay "fromDate"+ toDate <- lookDay "toDate"+ -- 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+ -- Generate the JSON data.+ okJson $ map+ (\entries ->+ case entries of+ [] -> M.fromList []+ ((tid,tsd,_,_):_) ->+ M.fromList [ (T.pack "task_id", toJSON $ hexEncode tid)+ , (T.pack "task_short_description", toJSON tsd)+ , (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+ ]+ 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+ ]
+ src/CQRSExample/Main.hs view
@@ -0,0 +1,80 @@+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (void, liftM)+import Data.CQRS+import Data.CQRS.EventStore.Backend.Sqlite3 (openSqliteEventStore)+import Data.Foldable (foldMap)+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 CQRSExample.Events+import CQRSExample.Instances ()+import CQRSExample.Json (jsonServerPart)+import CQRSExample.Query++sqliteFile :: String+sqliteFile = "example.db"++eventSourcingThread :: IConnection c => c -> EventStore Event -> IO ()+eventSourcingThread connection eventStore = do+ loop+ where+ loop = do+ putStrLn "Sourcing events..."+ reactToUnseenEvents connection eventStore+ -- Wait 1 second+ threadDelay 1000000+ -- Go again.+ loop++-- Check user.+checkUser :: IConnection c => c -> String -> String -> IO Bool+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"+ ]++--+test1 :: IO ()+test1 =+ do+ let queryDbFile = "query.db"++ -- Connect to query database+ conn <- connectSqlite3 queryDbFile+ setupQueryDatabase conn -- Perform any necessary setup.++ -- TODO: Should really do a "disconnect" too.++ -- Start sourcing events.+ _ <- forkIO $ do+ withEventStore (openSqliteEventStore sqliteFile) $ do+ eventSourcingThread conn++ -- Web serving thread.+ void $ forkIO $ do+ withEventStore (openSqliteEventStore sqliteFile) $ \eventStore ->+ serve Nothing $ myApp conn eventStore++ -- Perform site initialization if necessary.+ withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> do+ runTransactionT eventStore $ do+ void $ siteInitialization++main :: IO ()+main = do+ putStrLn "Running test1..."+ test1+ putStrLn "Press <Enter> to quit"+ _ <- getLine+ return ()
+ src/CQRSExample/Query.hs view
@@ -0,0 +1,214 @@+module CQRSExample.Query+ ( setupQueryDatabase+ , qFindUserPassword+ , qProjectList+ , qTaskList+ , qTimeSheet+ , qUserIdFromUserName+ , reactToUnseenEvents+ ) where++import Control.Monad (liftM, void)+import CQRSExample.Aggregates (UserId)+import CQRSExample.Events (Event(..))+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.Text (Text)+import Data.Time.Calendar (Day)+import Database.HDBC (IConnection, SqlValue(..), fromSql, quickQuery', run, runRaw, toSql, withTransaction)++-- Conversion between GUID and SQLValue.+instance Convertible GUID SqlValue where+ safeConvert g = Right $ toSql $ G.toByteString g++instance Convertible SqlValue GUID where+ safeConvert (SqlByteString s) = Right $ G.fromByteString s+ safeConvert a = convError "Invalid source value" a++-- Simple query with result field mapping.+smq :: IConnection c => c -> String -> [SqlValue] -> ([SqlValue] -> a) -> IO [a]+smq c sql params f = withTransaction c $ \_ ->+ fmap (map f) $ quickQuery' c sql params++-- Extract a single result (if any); fails if there is more than one result.+extract1 :: [a] -> Maybe a+extract1 [] = Nothing+extract1 [r] = Just r+extract1 _ = error "Too many results"++-- Initialize query database if necessary.+setupQueryDatabase :: IConnection c => c -> IO ()+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 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 )"++-- 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+ where+ convert :: [SqlValue] -> Text+ convert [p] = fromSql p+ convert _ = error "Invalid number of columns in SQL query result"++-- Query project list+qProjectList :: IConnection c => c -> IO [(GUID, Text, Text)]+qProjectList c = smq c "SELECT guid, name, short_desc FROM projects" [ ] convert+ where+ convert :: [SqlValue] -> (GUID, Text, Text)+ convert [spg, spn, spsd] = (fromSql spg, fromSql spn, fromSql spsd)+ 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 =+ 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+ 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+ where+ convert :: [SqlValue] -> (GUID,Text,Bool)+ convert [ guid, short_desc, starred_by_user ] =+ (fromSql guid,+ fromSql short_desc,+ case (fromSql starred_by_user :: Int) of+ 0 -> True+ 1 -> False+ _ -> error "Invalid query result")+ convert _ = error "Invalid columns in SQL query result"++-- 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"+ [ toSql $ show startDate+ , toSql $ show endDate+ , toSql userName ] convert)+ where+ convert :: [SqlValue] -> (GUID, Text, Maybe Day, Int)+ 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 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)+ -- React to all the events.+ forM_ evs $ reactToEvent connection+ -- Update the global version number.+ updateStartVersion $ startVersion + length evs+ -- Done.+ return ()++ where+ getStartVersion :: IO Int+ getStartVersion = do+ liftM head $ smq connection "SELECT COALESCE(MAX(gversion), 1) FROM gversion" [ ]+ (\columns -> case columns of+ [i] -> fromSql i+ _ -> error "Invalid columns in SQL query result")++ updateStartVersion :: Int -> IO ()+ updateStartVersion newStartVersion = do+ _ <- run connection "DELETE FROM gversion;" []+ _ <- run connection "INSERT INTO gversion (gversion) VALUES (?);" [ toSql newStartVersion ]+ return ()++reactToEvent :: IConnection c => c -> PersistedEvent Event -> IO ()+reactToEvent connection ev = do+ let gv = peGlobalVer ev+ let e = peEvent ev+ putStrLn $ show $ "gv(" ++ show gv ++ "): guid: " ++ show g ++ " event: " ++ show e+ react e+ where+ g = peAggregateGUID ev++ react (ProjectCreated pn psd) = do+ go "INSERT INTO projects ( guid , name , short_desc ) VALUES ( ? , ? , ? );"+ [ toSql g+ , toSql pn+ , toSql psd+ ]++ react (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 (?, ?, ?);"+ [ toSql g+ , toSql pid+ , toSql tsd ]++ react (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+ , toSql $ show wuDay+ , toSql $ wuDuration+ , toSql $ wuComment+ , toSql wuUserId+ ]++ react (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+ , toSql ucPassword+ , toSql ucFirstName+ , 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+ return () -- No need to record++ go :: String -> [SqlValue] -> IO ()+ go sql parameters = void $ run connection sql parameters
− src/Events.hs
@@ -1,74 +0,0 @@-module Events- ( Event(..)- ) where--import Aggregates-import Control.Monad (liftM)-import Data.CQRS (GUID)-import Data.Serialize (Serialize(..))-import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-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- 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 ucFirst ucLast) = do- put (4 :: Word8)- put $ encodeUtf8 ucUserName- put $ encodeUtf8 ucFirst- put $ encodeUtf8 ucLast- 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- ucFirst <- liftM decodeUtf8 get- ucLast <- liftM decodeUtf8 get- return $ UserCreated ucUserName ucFirst ucLast- _ -> do- fail $ "Unrecognized event type " ++ show i-
− src/Main.hs
@@ -1,130 +0,0 @@-import Control.Concurrent (forkIO, threadDelay)-import Control.Monad (liftM)-import Control.Monad.Trans.Class (lift)-import Data.Aeson (ToJSON, encode)-import Data.CQRS-import Data.CQRS.GUID (hexEncode)-import Data.CQRS.EventStore.Backend.Sqlite3-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Data.Time (fromGregorian)-import Database.SQLite3 (Database)-import Aggregates-import Events-import Instances ()-import Query-import Happstack.Lite--sqliteFile :: String-sqliteFile = "example.db"--eventSourcingThread :: Database -> EventStore Event -> IO ()-eventSourcingThread queryDb eventStore = do- loop- where- loop = do- putStrLn "Sourcing events..."- updateQueryStateRef queryDb eventStore- -- Wait 1 second- threadDelay 1000000- -- Go again.- loop---- Serve JSON ok response.-okJson :: ToJSON a => a -> ServerPart Response-okJson a = ok $ toResponseBS "text/json" $ encode a---- Serve JSON project list.-projectsJson :: Database -> ServerPart Response-projectsJson queryDb = do- p <- liftM (map f) $ lift $ qProjectList queryDb- okJson $ p- where- f (g,pn,psd) =- M.fromList [ (T.pack "id" , TE.decodeUtf8 $ hexEncode g)- , (T.pack "name" , pn)- , (T.pack "short_desc", psd)- ]---- Serve JSON task list.-tasksJson :: Database -> ServerPart Response-tasksJson queryDb = do- p <- liftM (map f) $ lift $ qTaskList queryDb- okJson $ p- where- f (g,tsd) =- M.fromList [ (T.pack "id" , TE.decodeUtf8 $ hexEncode g)- , (T.pack "short_description", tsd)- ]---- Serve JSON data.-jsonPart :: Database -> ServerPart Response-jsonPart queryDb =- msum- [ dir "projects" $ projectsJson queryDb- , dir "tasks" $ tasksJson queryDb- , dir "time-sheet" $ okJson ([ ] :: [String])- ]---- Serve.-myApp :: Database -> ServerPart Response-myApp queryDb = msum- [ dir "js" $ serveDirectory EnableBrowsing [ ] "static/js"- , dir "css" $ serveDirectory EnableBrowsing [ ] "static/css"- , dir "json" $ jsonPart queryDb- , serveDirectory EnableBrowsing [ "index.html" ] "static"- ]-----test1 :: IO ()-test1 =- do- let queryDbFile = "query.db"- -- Start sourcing events.- _ <- forkIO $ do- queryDb <- initializeQueryDatabase queryDbFile- withEventStore (openSqliteEventStore sqliteFile) $ eventSourcingThread queryDb-- -- Web serving thread.- _ <- forkIO $ do- queryDb <- initializeQueryDatabase queryDbFile- serve Nothing $ myApp queryDb-- -- Do a few things- withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> do- runTransactionT eventStore $ do- -- Create new project.- projectId <- lift $ newGUID- (projectRef, _ :: Project) <- getAggregateRoot projectId- publishEvent projectRef $ ProjectCreated "my project" "short desc of my project"-- -- Add a couple of tasks- taskId1 <- lift $ newGUID- (taskRef1, _ :: Task) <- getAggregateRoot taskId1- publishEvent taskRef1 $ TaskAdded projectId "tweak knob"-- taskId2 <- lift $ newGUID- (taskRef2, _ :: Task) <- getAggregateRoot taskId2- publishEvent taskRef2 $ TaskAdded projectId "pull lever"-- -- Rename project.- publishEvent projectRef $ ProjectRenamed "old project"-- -- Create user.- userId1 <- lift $ newGUID- (userRef1, _ :: User) <- getAggregateRoot userId1- publishEvent userRef1 $ UserCreated "bardur" "Bardur" "Arantsson"-- -- Record time for task #2.- workUnitId1 <- lift $ newGUID- publishEvent taskRef2 $ RecordedWorkUnit workUnitId1 (fromGregorian 2011 12 01) 3 "found the lever to pull" userId1---main :: IO ()-main = do- putStrLn "Running test1..."- test1- putStrLn "Press <Enter> to quit"- _ <- getLine- return ()
− src/Query.hs
@@ -1,123 +0,0 @@-module Query ( initializeQueryDatabase- , updateQueryStateRef- , qProjectList- , qTaskList- ) where--import Control.Monad (forM_, liftM)-import Data.ByteString (ByteString)-import Data.CQRS (enumerateEventStore, GUID, EventStore)-import Data.CQRS.EventStore.Backend.Sqlite3Utils (withTransaction, execSql, enumQueryResult)-import Data.Enumerator (run_, (>>==), ($=))-import qualified Data.Enumerator.List as EL-import Data.Serialize (Serialize, decode, encode)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Database.SQLite3 as SQL-import Database.SQLite3 (Database, SQLData(..))-import Events (Event(..))---- TODO: Export Data.CQRS.Serialize decode' instead?-decode' :: Serialize a => ByteString -> a-decode' = either error id . decode---- Initialize the query state.-initializeQueryDatabase :: String -> IO Database-initializeQueryDatabase databaseFileName = do- -- Open database.- database <- SQL.open databaseFileName- -- Create prerequisite tables if necessary.- execSql database "CREATE TABLE IF NOT EXISTS gversion ( gversion INTEGER )" []- execSql database "CREATE TABLE IF NOT EXISTS projects ( guid BLOB , name TEXT , short_desc TEXT )" []- execSql database "CREATE TABLE IF NOT EXISTS tasks ( guid BLOB , project_guid BLOB , short_desc TEXT , long_desc TEXT )" []- execSql database "CREATE TABLE IF NOT EXISTS users ( user_id BLOB , user_name TEXT , first_name TEXT , last_name TEXT )" []- execSql database "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 )" []- -- Return the open database.- return database---- React to event.-reactToEvent :: Database -> (Int, (GUID, Int, Event)) -> IO ()-reactToEvent database (gv, (g, _, e)) = do- putStrLn $ show $ "gv(" ++ show gv ++ "): event: " ++ show e- react e- where- react (ProjectCreated pn psd) = do- execSql database "INSERT INTO projects ( guid , name , short_desc ) VALUES ( ? , ? , ? );" [ SQLBlob $ encode g , SQLText $ T.unpack pn , SQLText $ T.unpack psd ]-- react (ProjectRenamed pn) = do- execSql database "UPDATE projects SET name = ? WHERE guid = ?;" [ SQLText $ T.unpack pn , SQLBlob $ encode g ]-- react (TaskAdded pid tsd) = do- execSql database "INSERT INTO tasks ( guid , project_guid , short_desc ) VALUES (?, ?, ?);" [ SQLBlob $ encode g, SQLBlob $ encode pid , SQLText $ T.unpack tsd ]-- react (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do- execSql database "INSERT INTO work_units ( task_guid , wu_guid , wu_date , wu_duration , wu_comment , user_id ) VALUES ( ? , ? , ? , ? , ? , ? );"- [ SQLBlob $ encode g- , SQLBlob $ encode wuId- , SQLText $ show wuDay- , SQLInteger $ fromIntegral wuDuration- , SQLText $ T.unpack wuComment- , SQLBlob $ encode wuUserId- ]-- react (UserCreated ucUserName ucFirstName ucLastName) = do- execSql database "INSERT INTO users ( user_id , user_name , first_name , last_name ) VALUES ( ? , ? , ? , ? );"- [ SQLBlob $ encode g- , SQLText $ T.unpack ucUserName- , SQLText $ T.unpack ucFirstName- , SQLText $ T.unpack ucLastName- ]---- Get the global version number.-getStartVersion :: Database -> IO Int-getStartVersion queryDatabase = do- lastVersion <-- liftM head $- run_ $ EL.consume >>==- (enumQueryResult queryDatabase "SELECT COALESCE(MAX(gversion), 1) FROM gversion" [] $=- (EL.map (\columns -> case columns of- [ SQLInteger i ] -> fromIntegral i- _ -> error "Invalid columns in SQL query result")))- return $ lastVersion--updateStartVersion :: Database -> Int -> IO ()-updateStartVersion queryDatabase newStartVersion = do- execSql queryDatabase "DELETE FROM gversion;" []- execSql queryDatabase "INSERT INTO gversion (gversion) VALUES (?);" [ SQLInteger $ fromIntegral $ newStartVersion ]---- Update query state with latest events.-updateQueryStateRef :: Database -> EventStore Event -> IO ()-updateQueryStateRef queryDatabase eventStore =- withTransaction queryDatabase $ do- -- Find the version number to start at.- startVersion <- getStartVersion queryDatabase- -- Enumerate all the events form the event store since last run.- evs <- run_ (EL.consume >>== enumerateEventStore eventStore startVersion)- -- React to all the events.- forM_ evs $ reactToEvent queryDatabase- -- Update the global version number.- updateStartVersion queryDatabase $ startVersion + length evs- -- Done.- return ()---- Query project list-qProjectList :: Database -> IO [(GUID, Text, Text)]-qProjectList queryDatabase = do- run_ $ EL.consume >>==- (enumQueryResult queryDatabase "SELECT guid, name, short_desc FROM projects" [] $=- (EL.map (\columns -> case columns of- [ SQLBlob guid, SQLText name, SQLText short_desc ] ->- (decode' guid , T.pack name, T.pack short_desc)- _ ->- error "Invalid columns in SQL query result")))---- Query task list-qTaskList :: Database -> IO [(GUID, Text)]-qTaskList queryDatabase = do- run_ $ EL.consume >>==- (enumQueryResult queryDatabase "SELECT guid, short_desc FROM tasks;" [] $=- (EL.map (\columns -> case columns of- [ SQLBlob guid, SQLText short_desc ] ->- (decode' guid, T.pack short_desc)- _ ->- error "Invalid columns in SQL query result")))