Aggregates.hs

module CQRSExample.Aggregates
       ( Project(..)
       , ProjectId
       , Site(..)
       , siteGUID
       , Task(..)
       , TaskId
       , User(..)
       , UserId
       , WorkUnit(..)
       , WorkUnitId
       ) where

import           Control.Monad (liftM)
import           Data.CQRS (Aggregate(..), GUID)
import           Data.CQRS.Serialize (decode')
import           Data.Default (Default(..))
import           Data.Map (Map)
import           Data.Set (Set)
import qualified Data.Set as S
import           Data.Serialize (Serialize(..), 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

-- Instance for Text. We'll just serialize all of it as UTF-8,
-- there's very little point in doing otherwise for our use case.
instance Serialize Text where
  put = put . encodeUtf8
  get = fmap decodeUtf8 get

-- Site aggregate. This keeps track of things which must be "per site"
-- (per installation), e.g. a list of used user names such that we
-- can be sure that there are no users with the same login name.
--
-- Note that only data required for command verification is necessary
-- here!
data Site = Site { sUserNames :: Set Text
                 } deriving (Typeable, Eq, Show)

instance Serialize Site where
  put (Site suns) =
    put suns
  get = do
    fmap Site get

instance Aggregate Site where
  encodeAggregate = encode
  decodeAggregate = decode'

instance Default Site where
  def = Site S.empty

-- GUID for the single Site aggregate.
siteGUID :: GUID
siteGUID = def

-- 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 = decode'

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 = decode'

instance Default Task where
  def = NewTask

-- Users.

type UserId = GUID

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

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

instance Aggregate User where
  encodeAggregate = encode
  decodeAggregate = decode'

instance Default User where
  def = UncreatedUser


-- Work Units (NOT aggregates!)
type WorkUnitId = GUID

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