cqrs-example-0.6.0: src/Aggregates.hs

module Aggregates
       ( Project(..)
       , ProjectId
       , Task(..)
       , TaskId
       , User(..)
       , UserId
       , WorkUnit(..)
       ) where

import Control.Monad (liftM)
import Data.CQRS (Aggregate(..), GUID)
import Data.Default (Default(..))
import Data.Map (Map)
import Data.Serialize (Serialize(..), decode, encode)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time.Calendar(Day(..), toGregorian, fromGregorian)
import Data.Typeable (Typeable)
import Data.Word (Word8)

-- Instances for Haskell built-ins.
instance Serialize Day where
  put = put . toGregorian
  get = do
    (a,b,c) <- get
    return $ fromGregorian a b c

-- Projects.

type ProjectId = GUID

data Project = DefaultProject
             | ActiveProject { projectName :: Text
                             , projectCustomer :: Text
                             }
             deriving (Typeable, Eq, Show)

instance Serialize Project where
  put DefaultProject = do
    put (0 :: Word8)
  put (ActiveProject pn pc) = do
    put (1 :: Word8)
    put $ encodeUtf8 pn
    put $ encodeUtf8 pc
  get = do
    i :: Word8 <- get
    case i of
      0 -> return DefaultProject
      1 -> do
        pn <- liftM decodeUtf8 get
        pc <- liftM decodeUtf8 get
        return $ ActiveProject pn pc
      _ ->
        fail $ "Cannot decode project state" ++ show i

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

instance Default Project where
  def = DefaultProject

-- Tasks.

type TaskId = GUID

data Task = NewTask
          | ActiveTask { taskProjectId :: ProjectId
                       , taskShortDescription :: Text
                       , taskLongDescription :: Text
                       , taskWorkUnits :: Map Day WorkUnit
                       }
          deriving (Typeable, Eq, Show)

instance Serialize Task where
  put NewTask = do
    put (0 :: Word8)
  put (ActiveTask tpid tsd tld twu) = do
    put (1 :: Word8)
    put tpid
    put $ encodeUtf8 tsd
    put $ encodeUtf8 tld
    put twu
  get = do
    i :: Word8 <- get
    case i of
      0 -> return NewTask
      1 -> do
        tpid <- get
        tsd <- liftM decodeUtf8 get
        tld <- liftM decodeUtf8 get
        twu <- get
        return $ ActiveTask tpid tsd tld twu
      _ ->
        fail $ "Cannot decode task state: " ++ show i


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

instance Default Task where
  def = NewTask

-- Users.

type UserId = GUID

data User = UncreatedUser
          | ActiveUser { auUserName :: Text
                       , auLastName :: Text
                       , auFirstName :: Text
                       }
            deriving (Typeable, Eq, Show)

instance Serialize User where
  put UncreatedUser = do
    put $ (0 :: Word8)
  put (ActiveUser auun auln aufn) = do
    put $ (1 :: Word8)
    put $ encodeUtf8 auun
    put $ encodeUtf8 auln
    put $ encodeUtf8 aufn
  get = do
    i :: Word8 <- get
    case i of
      0 -> return UncreatedUser
      1 -> do
        auun <- liftM decodeUtf8 get
        auln <- liftM decodeUtf8 get
        aufn <- liftM decodeUtf8 get
        return $ ActiveUser auun auln aufn
      _ ->
        fail $ "Cannot decode user state: " ++ show i

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

instance Default User where
  def = UncreatedUser


-- Work Units (NOT aggregates!)
data WorkUnit = WorkUnit { workUnitId :: GUID
                         , workUnitComment :: Text
                         , workUnitDuration :: Integer
                         , workUnitUser :: UserId
                         }
                deriving (Eq, Show)

instance Serialize WorkUnit where
  put (WorkUnit wuid wuc wud wuu) = do
    put $ wuid
    put $ encodeUtf8 wuc
    put wud
    put wuu
  get = do
    wuid <- get
    wuc <- liftM decodeUtf8 get
    wud <- get
    wuu <- get
    return $ WorkUnit wuid wuc wud wuu