cqrs-example-0.4.0: src/Aggregates.hs

module Aggregates
       ( Project(..)
       , ProjectId
       , ProjectState(..)
       , Task(..)
       , TaskId
       , TaskState(..)
       ) where

import Control.Monad (liftM)
import Data.CQRS (Aggregate(..), GUID)
import Data.Default (Default(..))
import Data.Serialize (Serialize(..), decode, encode)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable (Typeable)
import Data.Word (Word8)

-- Projects.

type ProjectId = GUID Project

data ProjectState = New
                  | Active
                  deriving (Eq, Typeable)

instance Serialize ProjectState where
  put New = put (0 :: Word8)
  put Active = put (1 :: Word8)
  get = do
    i :: Word8 <- get
    case i of
      0 -> return New
      1 -> return Active
      _ -> fail $ "Cannot decode project state: " ++ show i

data Project = Project { projectName :: Text
                       , projectState :: ProjectState
                       }
               deriving (Typeable)

instance Serialize Project where
  put (Project pn ps) = do
    put $ encodeUtf8 pn
    put ps
  get = do
    pn <- liftM decodeUtf8 get
    ps <- get
    return $ Project pn ps

instance Aggregate Project where
  encodeAggregate = encode
  decodeAggregate s =
    case decode s of
      Left e -> error e
      Right a -> a

instance Default Project where
  def = Project T.empty New

-- Tasks.

type TaskId = GUID Task

data TaskState = TaskNew
               | TaskActive
                 deriving (Eq, Typeable)

instance Serialize TaskState where
  put TaskNew = put (0 :: Word8)
  put TaskActive = put (1 :: Word8)
  get = do
    i :: Word8 <- get
    case i of
      0 -> return TaskNew
      1 -> return TaskActive
      _ -> fail $ "Cannot decode task state: " ++ show i

data Task = Task { taskProjectId :: ProjectId
                 , taskState :: TaskState
                 , taskShortDescription :: Text
                 }
            deriving (Typeable)

instance Serialize Task where
  put (Task tpid ts tsd) = do
    put tpid
    put ts
    put $ encodeUtf8 tsd
  get = do
    tpid <- get
    ts <- get
    tsd <- liftM decodeUtf8 get
    return $ Task tpid ts tsd

instance Aggregate Task where
  encodeAggregate = encode
  decodeAggregate s =
    case decode s of
      Left e -> error e
      Right a -> a

instance Default Task where
  def = Task def TaskNew T.empty