Skip to content

Instantly share code, notes, and snippets.

@Fristi
Last active November 6, 2022 20:50
Show Gist options
  • Star 35 You must be signed in to star a gist
  • Fork 8 You must be signed in to fork a gist
  • 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
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@gmail.com"]
print $ execute seed $ ChangeEmail "email@gmail.com"
print $ execute seed $ ChangeName "Te"
@theduke
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.

@jdreaver
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)

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

@jonashw
Copy link

jonashw commented Aug 28, 2016

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

@jonashw
Copy link

jonashw commented Sep 25, 2016

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

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