diff --git a/cqrs-example.cabal b/cqrs-example.cabal --- a/cqrs-example.cabal +++ b/cqrs-example.cabal @@ -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 diff --git a/src/Aggregates.hs b/src/Aggregates.hs deleted file mode 100644 --- a/src/Aggregates.hs +++ /dev/null @@ -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 diff --git a/src/CQRSExample/Aggregates.hs b/src/CQRSExample/Aggregates.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Aggregates.hs @@ -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 diff --git a/src/CQRSExample/Command.hs b/src/CQRSExample/Command.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Command.hs @@ -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 diff --git a/src/CQRSExample/Controller/Auth.hs b/src/CQRSExample/Controller/Auth.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Controller/Auth.hs @@ -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) diff --git a/src/CQRSExample/Events.hs b/src/CQRSExample/Events.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Events.hs @@ -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 diff --git a/src/CQRSExample/Instances.hs b/src/CQRSExample/Instances.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Instances.hs @@ -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 } diff --git a/src/CQRSExample/Json.hs b/src/CQRSExample/Json.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Json.hs @@ -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 + ] diff --git a/src/CQRSExample/Main.hs b/src/CQRSExample/Main.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Main.hs @@ -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 to quit" + _ <- getLine + return () diff --git a/src/CQRSExample/Query.hs b/src/CQRSExample/Query.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Query.hs @@ -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 (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 diff --git a/src/Events.hs b/src/Events.hs deleted file mode 100644 --- a/src/Events.hs +++ /dev/null @@ -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 - diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 to quit" - _ <- getLine - return () diff --git a/src/Query.hs b/src/Query.hs deleted file mode 100644 --- a/src/Query.hs +++ /dev/null @@ -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")))