Events.hs

module CQRSExample.Events
       ( Event(..)
       ) where

import           Control.Monad (liftM)
import           CQRSExample.Aggregates
import           Data.CQRS (GUID)
import           Data.Serialize (Serialize(..))
import           Data.Text (Text)
import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
import           Data.Time.Calendar (Day)
import           Data.Typeable (Typeable)
import           Data.Word (Word8)

data Event = ProjectCreated Text Text
           | ProjectRenamed Text
           | TaskAdded ProjectId Text
           | RecordedWorkUnit GUID Day Integer Text UserId
           | UserCreated Text Text Text Text
           | UserRegistered Text
           | TaskStarred UserId
           | TaskUnstarred UserId
           deriving (Typeable, Show)

instance Serialize Event where
  put (ProjectCreated name shortDesc) = do
    put (0 :: Word8)
    put $ encodeUtf8 name
    put $ encodeUtf8 shortDesc
  put (ProjectRenamed name) = do
    put (1 :: Word8)
    put $ encodeUtf8 name
  put (TaskAdded pid tsd) = do
    put (2 :: Word8)
    put $ pid
    put $ encodeUtf8 tsd
  put (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do
    put (3 :: Word8)
    put $ wuId
    put $ wuDay
    put $ wuDuration
    put $ encodeUtf8 wuComment
    put wuUserId
  put (UserCreated ucUserName ucPassword ucFirst ucLast) = do
    put (4 :: Word8)
    put $ encodeUtf8 ucUserName
    put $ encodeUtf8 ucPassword -- FIXME: Should really hash the password, shouldn't we?
    put $ encodeUtf8 ucFirst
    put $ encodeUtf8 ucLast
  put (TaskStarred userId) = do
    put (5 :: Word8)
    put userId
  put (TaskUnstarred userId) = do
    put (6 :: Word8)
    put userId
  put (UserRegistered userId) = do
    put (7 :: Word8)
    put userId
  get = do
    i :: Word8 <- get
    case i of
      0 -> do
        n <- liftM decodeUtf8 get
        sd <- liftM decodeUtf8 get
        return $ ProjectCreated n sd
      1 -> do
        n <- liftM decodeUtf8 get
        return $ ProjectRenamed n
      2 -> do
        pid <- get
        tsd <- liftM decodeUtf8 get
        return $ TaskAdded pid tsd
      3 -> do
        wuId <- get
        wuDay <- get
        wuDuration <- get
        wuComment <- liftM decodeUtf8 get
        wuUserId <- get
        return $ RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId
      4 -> do
        ucUserName <- liftM decodeUtf8 get
        ucPassword <- liftM decodeUtf8 get
        ucFirst <- liftM decodeUtf8 get
        ucLast <- liftM decodeUtf8 get
        return $ UserCreated ucUserName ucPassword ucFirst ucLast
      5 -> do
        userId <- get
        return $ TaskStarred userId
      6 -> do
        userId <- get
        return $ TaskUnstarred userId
      7 -> do
        userId <- get
        return $ UserRegistered userId
      _ -> do
        fail $ "Unrecognized event type " ++ show i