Command.hs

module CQRSExample.Command
       ( archiveCompletedTasks
       , createTask
       , completeTask
       , reopenTask
       ) where

import           Control.Concurrent.STM.TVar (TVar)
import           Control.Monad (forM_)
import           Control.Monad.Trans.Class (lift)
import           Data.CQRS.Command (createAggregate, loadAggregate, newGUID, publishEvent, UnitOfWorkT, AggregateRef)
import           Data.Text (Text)

import           CQRSExample.Aggregates
import           CQRSExample.Events
import           CQRSExample.Instances ()
import           CQRSExample.Query (QueryState, runQuery, qCompletedTaskIdList)

-- Create new task in a project.
createTask :: Text -> UnitOfWorkT Event IO TaskId
createTask title = do
  taskId <- lift $ newGUID
  (taskRef :: AggregateRef Task Event) <- createAggregate taskId
  publishEvent taskRef $ TaskEvent $ TaskAdded title
  return taskId

-- Complete a task.
completeTask :: TaskId -> UnitOfWorkT Event IO ()
completeTask taskId = do
  (taskRef, task :: Task) <- loadAggregate taskId
  case taskStatus task of
    TaskStatusOpen     -> publishEvent taskRef $ TaskEvent $ TaskCompleted
    TaskStatusComplete -> return ()
    TaskStatusArchived -> return ()

-- Reopen a task.
reopenTask :: TaskId -> UnitOfWorkT Event IO ()
reopenTask taskId = do
  (taskRef, task :: Task) <- loadAggregate taskId
  case taskStatus task of
    TaskStatusOpen     -> return ()
    TaskStatusComplete -> publishEvent taskRef $ TaskEvent $ TaskReopened
    TaskStatusArchived -> return ()

archiveCompletedTasks :: TVar QueryState -> UnitOfWorkT Event IO ()
archiveCompletedTasks qs = do
  taskIds <- lift $ runQuery qs qCompletedTaskIdList
  forM_ taskIds $ \taskId -> do
    (taskRef, task :: Task) <- loadAggregate taskId
    case taskStatus task of
      TaskStatusOpen     -> return ()
      TaskStatusComplete -> publishEvent taskRef $ TaskEvent $ TaskArchived
      TaskStatusArchived -> return ()