Aggregate.hs

-- | Defines an Aggregate type-class from DDD parlance.

module Eventful.Aggregate
  ( Aggregate (..)
  , allAggregateStates
  , commandStoredAggregate
  ) where

import Data.Foldable (foldl')
import Data.List (scanl')

import Eventful.Projection
import Eventful.Store.Class
import Eventful.UUID

-- | An 'Aggregate' is a combination of a 'Projection' and a function to
-- validate commands against that 'Projection'. When using an aggregate in some
-- service, it is common to simply load the latest projection state from the
-- event store and handle the command. If the command is valid then the new
-- events are applied to the projection in the event store.
data Aggregate state event cmd =
  Aggregate
  { aggregateCommandHandler :: state -> cmd -> [event]
  , aggregateProjection :: Projection state event
  }

-- | Given a list commands, produce all of the states the aggregate's
-- projection sees. This is useful for unit testing aggregates.
allAggregateStates
  :: Aggregate state event cmd
  -> [cmd]
  -> [state]
allAggregateStates (Aggregate commandHandler (Projection seed eventHandler)) events =
  scanl' go seed events
  where
    go state command = foldl' eventHandler state $ commandHandler state command

-- | Loads the latest version of a 'Projection' from the event store and tries to
-- apply the 'Aggregate' command to it. If the command succeeds, then this
-- saves the events back to the store as well.
commandStoredAggregate
  :: (Monad m)
  => EventStore serialized m
  -> Aggregate state serialized cmd
  -> UUID
  -> cmd
  -> m [serialized]
commandStoredAggregate store (Aggregate handler proj) uuid command = do
  (latest, vers) <- getLatestProjection store proj uuid
  let events = handler latest command
  mError <- storeEvents store (ExactVersion vers) uuid events
  case mError of
    (Just err) -> error $ "TODO: Create aggregate restart logic. " ++ show err
    Nothing -> return events