DDD/Event Sourcing in Haskell. Implemented an aggregate as a type class and type families to couple event, command and error types specific to the aggregate. Errors are returned by using Either (Error e) (Event e). Applying Applicative Functors fits here well to sequentially check if the command suffice.

Aggregate.hs

{-# LANGUAGE TypeFamilies #-}

import Data.Function (on)
import Control.Applicative

data EventData e = EventData {
    eventId :: Int,
    body :: Event e
}

instance Show (EventData e) where
    show = show . eventId

instance Eq (EventData e) where
    (==) = (==) `on` eventId

instance Ord (EventData e) where
    compare = compare `on` eventId

class Aggregate s where
    data Error s :: *
    data Command s :: *
    data Event s :: *

    execute :: s -> Command s -> Either (Error s) (Event s)
    apply :: s -> Event s -> s
    seed :: s



data User = User {
    name :: String,
    email :: String
} deriving (Show)

instance Aggregate User where

    data Error User = NotAllowed
                    | TooShortUsername Int Int
                    | EmptyUsername
                    | EmptyEmail
                    deriving (Show)

    data Event User = NameChanged String 
                    | EmailChanged String 
                    deriving (Show)
    
    data Command User = ChangeName String 
                      | ChangeEmail String
                      deriving (Show) 

    _ `execute` ChangeName n = NameChanged 
        <$> validate notEmpty EmptyUsername n
        <* validate (lengthBetween 4 8) (TooShortUsername 4 8) n

    _ `execute` ChangeEmail e = EmailChanged 
        <$> validate notEmpty EmptyEmail e

    state `apply` NameChanged n = state { name = n }
    state `apply` EmailChanged e = state { email = e }

    seed = User "" ""

load :: (Aggregate a) => [EventData a] -> a
load = foldl folder seed
    where
        folder state = apply state . body

validate :: (a -> Bool) -> e -> a -> Either e a
validate f err x
    | f x = Right x
    | otherwise = Left err

notEmpty :: [a] -> Bool
notEmpty = (> 0) . length

lengthBetween :: Int -> Int -> String -> Bool
lengthBetween s e str
    | len >= s && len <= e = True
    | otherwise = False
    where len = length str

main :: IO()
main = do

    print $ load $ map (EventData 1) [NameChanged "Borak", NameChanged "Fristi", EmailChanged "[email protected]"]
    print $ execute seed $ ChangeEmail "[email protected]"
    print $ execute seed $ ChangeName "Te"

isn't it this usage of type families equivalent to a record in the absence of type level computation ? edit answering my own question : it's easier to mutually reference other fields

Very nice @Fristi. Just one question.

I am quite sure I am missing, but I was thinking about how to execute a command in the Domain Model and was thinking that part of executing a command is about changing the state of the Aggregate and also raise events about that command that was executed. This means that other Services that are interesting in Events happening at the Domain Model can subscribe to those events.

Because of this I was thinking about combining this 2 functions:

    execute :: s -> Command s -> Either (Error s) (Event s)
    apply :: s -> Event s -> s

into one function

    execute :: s -> Command s -> Either (Error s) (Event s, s)

That performs the action and raise events about changes of state so other service can monitor those events. Maybe you can say that the Domain Model is also subscribing itself it's own events by defining apply. Do you have any thoughts about this?

@damiansoriano: in event sourcing / CQRS replaying events is an important functionality.
You can always restore an aggregate to a specific point in time by applying the events.
In a replay, the command must not be executed though, because all the side effects are not supposed to happen again.

That's why you can't combine the two.

I just wanted to share that I found some utility in splitting up the Aggregate class here into Projection and Aggregate:

class Projection s where
  data Event s :: *

  seed :: s
  apply :: s -> Event s -> s

class (Projection s) => Aggregate s where
  data Command s :: *
  data Error s :: *

  execute :: s -> Command s -> Either (Error s) (Event s)

Very nice! I think it would be better for 'aggregate' to accept an arbitrary monad that 'execute' operates in (instead of encoding Error and Either in the types), that way you could interleave various effects (IO, exceptions) when executing a command.

Anybody have an example of how a repository for this aggregate would look?

@jdreaver: would you mind explaining the utility you get from adding a Projection class?

State is not an Aggregate. An aggregate is just a function which keeps invariant and produces event/error.