module Data.CQRS.Transaction
( TransactionT
, runTransactionT
, publishEvent
, getAggregateRoot
) where
import Control.Monad (forM_)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (MonadTrans(..), lift)
import Control.Monad.Trans.State (StateT, get, modify, runStateT)
import Data.Binary (Binary)
import Data.CQRS.Internal.AggregateRef (AggregateRef, mkAggregateRef)
import qualified Data.CQRS.Internal.AggregateRef as AR
import Data.CQRS.Event (Event(..))
import Data.CQRS.EventStore (EventStore, withTransaction)
import qualified Data.CQRS.EventStore as ES
import Data.CQRS.GUID (GUID)
import Data.Default (Default(..))
import Data.List (find)
import Data.Typeable (Typeable, cast)
newtype TransactionT m a = TransactionT (Transaction m a)
deriving (Functor, Monad)
instance MonadTrans TransactionT where
lift m = TransactionT $ lift m
data BoxedAggregateRef =
forall a e . (Typeable a, Typeable e, Event e a, Default a, Binary e) => BoxedAggregateRef (AggregateRef a e)
type Transaction = StateT TransactionState
data TransactionState =
TransactionState { eventStore :: EventStore
, aggregateRefsToCommit :: [BoxedAggregateRef]
}
runTransactionT :: EventStore -> TransactionT IO a -> IO a
runTransactionT eventStore_ (TransactionT transaction) = do
withTransaction eventStore_ $ do
(r,s) <- runStateT transaction s0
forM_ (aggregateRefsToCommit s) $ \(BoxedAggregateRef a) -> do
es <- AR.readEvents a
ES.storeEvents eventStore_ (AR.arGUID a) (AR.arStartVersion a) es
return r
where s0 = TransactionState eventStore_ [ ]
getById :: forall a e . (Typeable a, Typeable e, Event e a, Default a, Binary e) => GUID a -> TransactionT IO (AggregateRef a e)
getById guid = TransactionT $ do
aggregateRefs <- fmap aggregateRefsToCommit get
case find (\(BoxedAggregateRef a) ->
case cast $ AR.arGUID a of
Just (guid' :: GUID a) -> guid == guid'
Nothing -> False) aggregateRefs of
Just (BoxedAggregateRef a) ->
case cast a of
Just (a' :: AggregateRef a e) -> return a'
Nothing ->
fail $ concat ["Duplicate GUID ", show guid, "!" ]
Nothing -> do
getByIdFromEventStore guid
getByIdFromEventStore :: forall a e . (Typeable a, Typeable e, Event e a, Default a, Binary e) => GUID a -> Transaction IO (AggregateRef a e)
getByIdFromEventStore guid = do
es <- fmap eventStore get
(latestVersion :: Int, events :: [e]) <-
lift $ (ES.retrieveEvents es $ guid :: IO (Int,[e]))
let a = foldr applyEvent def events
(a' :: AggregateRef a e) <- lift $ mkAggregateRef a guid latestVersion
modify $ \s -> s { aggregateRefsToCommit = (BoxedAggregateRef a' : aggregateRefsToCommit s) }
return a'
publishEvent :: (MonadIO m, Event e a) => AggregateRef a e -> e -> TransactionT m ()
publishEvent aggregateRef event = lift $ AR.publishEvent aggregateRef event
getAggregateRoot :: (Default a, Binary e, Event e a, Typeable a, Typeable e) => GUID a -> TransactionT IO (AggregateRef a e, a)
getAggregateRoot guid = do
aggregateRef <- getById guid
aggregate <- lift $ AR.readValue aggregateRef
return (aggregateRef, aggregate)