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.Duration (Duration) import CQRSExample.Events import CQRSExample.Instances () import Data.CQRS import qualified Data.Set as S import Data.Text (Text) import Data.Time.Calendar (Day) import Data.Time.Clock (getCurrentTime) -- Perform any needed site initialization. siteInitialization :: TransactionT Event IO () 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 $ SiteEvent $ UserRegistered userName -- Publish to the user aggregate. userId <- lift $ newGUID (userRef, _ :: User) <- getAggregateRoot userId publishEvent userRef $ UserEvent $ 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 $ ProjectEvent $ ProjectCreated name shortDescription return projectId -- Rename project. renameProject :: ProjectId -> Text -> TransactionT Event IO () renameProject projectId newName = do (projectRef, _ :: Project) <- getAggregateRoot projectId publishEvent projectRef $ ProjectEvent $ ProjectRenamed newName -- Create new task in a project. createTask :: ProjectId -> Text -> Duration -> UserId -> TransactionT Event IO TaskId createTask projectId shortDescription estimate userId = do taskId <- lift $ newGUID (taskRef, _ :: Task) <- getAggregateRoot taskId ts <- lift $ getCurrentTime publishEvent taskRef $ TaskEvent $ TaskAdded projectId shortDescription estimate userId ts return taskId -- Star a task. starTask :: TaskId -> UserId -> TransactionT Event IO () starTask taskId userId = do (taskRef, _ :: Task) <- getAggregateRoot taskId publishEvent taskRef $ TaskEvent $ TaskStarred userId return () -- Unstar a task. unstarTask :: TaskId -> UserId -> TransactionT Event IO () unstarTask taskId userId = do (taskRef, _ :: Task) <- getAggregateRoot taskId publishEvent taskRef $ TaskEvent $ TaskUnstarred userId return () -- Log work. Returns the GUID of the newly logged work. logWork :: TaskId -> UserId -> Day -> Duration -> Text -> TransactionT Event IO WorkUnitId logWork taskId userId day duration comment = do -- Find the task. (taskRef, _ :: Task) <- getAggregateRoot taskId -- Publish the event to the task. wid <- lift $ newGUID publishEvent taskRef $ TaskEvent $ RecordedWorkUnit wid day duration comment userId return wid