Aggregates.hs

module CQRSExample.Aggregates
       ( newTask
       , Task(..)
       , TaskId
       , TaskStatus(..)
       ) where

import           Control.DeepSeq (NFData(..))
import           Control.Monad (unless)
import           Data.CQRS.Command (Aggregate)
import           Data.CQRS.GUID (GUID)
import           Data.CQRS.Serializable (Serializable(..))
import           Data.DeriveTH (derive, makeNFData)
import           Data.Serialize (Serialize(..), getWord8, putWord8, encode, decode)
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Typeable (Typeable)

-- Tasks.

type TaskId = GUID

data TaskStatus = TaskStatusOpen
                | TaskStatusComplete
                | TaskStatusArchived
                  deriving (Typeable, Eq, Show)

data Task = Task
    { taskTitle :: Text
    , taskStatus :: TaskStatus
    } deriving (Typeable, Eq, Show)

newTask :: Text -> Task
newTask title = Task title TaskStatusOpen

-- Serialize instances. In the case of aggregates
-- compatibility is not that important and de-serialization
-- can fail without huge host, i.e. the aggregate has to
-- be reconstructed from events rather than using the
-- snapshot. It *is* important that a format change is
-- detected, though, which is why we're just putting in
-- a "version" marker.

instance Serialize TaskStatus where
    put status = do
      putWord8 1 -- Version number.
      case status of
        TaskStatusOpen -> putWord8 1
        TaskStatusComplete -> putWord8 2
        TaskStatusArchived -> putWord8 3
    get = do
      v <- getWord8 -- Version number.
      unless (v == 1) $ fail "Not the correct version"
      i <- getWord8
      case i of
        1 -> return TaskStatusOpen
        2 -> return TaskStatusComplete
        3 -> return TaskStatusArchived
        _ -> error "Versioning inconsistency; this is BAD"

instance Serialize Task where
    put (Task t1 t2) = do
      putWord8 1 -- Version marker.
      put $ T.unpack t1
      put t2
    get = do
      v <- getWord8 -- Version number
      unless (v == 1) $ fail "Not the correct version"
      t1 <- fmap T.pack get
      t2 <- get
      return $ Task t1 t2

-- NFData instances.
$(derive makeNFData ''TaskStatus)
$(derive makeNFData ''Task)

-- Serializable instance.
instance Serializable Task where
    serialize = encode
    deserialize = either (const Nothing) Just . decode

-- Aggregate instance.
instance Aggregate Task