Command.hs

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