Skip to content

Instantly share code, notes, and snippets.

Last active November 6, 2022 20:50
Show Gist options
  • Save Fristi/7327904 to your computer and use it in GitHub Desktop.
Save Fristi/7327904 to your computer and use it in GitHub Desktop.
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.
{-# 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
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 ""]
print $ execute seed $ ChangeEmail ""
print $ execute seed $ ChangeName "Te"
Copy link

nice one!

Copy link

notEmpty = not . null is better, and doesn't attempt to evaluate possibly long or infinite lists.

Copy link

nrolland commented Jan 7, 2016

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

Copy link

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?

Copy link

theduke commented Apr 23, 2016

@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.

Copy link

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)

Copy link

nmdanny commented Aug 16, 2016

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.

Copy link

jonashw commented Aug 28, 2016

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

Copy link

jonashw commented Sep 25, 2016

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

Copy link

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment