Playing with event-sourcing

Question

I'm playing around with some ideas about how to read aggregates from events.

From a high-level view I would love to have this:

class Apply ev ag where
  apply :: ag -> ev -> ag

which to define how an Event ev should change an Aggregate ag if there is an instance of this class for the pair (if there is none then the aggregate should ignore the event).

If you look at the code below it's not hard at all to do it (please forgive me the anti-pattern with the Event list there).

My problem starts when I want the events all serialized - or better: once I want them deserialized and applied again (to be honest: I don't care about the representations at all - but it should be possible to fold an aggregate from a heterogeneous list/stream of serialized events of course).

What I don't like about my solution is this ugly bit of boiler-plate:

instance DeserializableFor Person where
  tryDeserialize (tn, sn)
    | tn == typeOf (SetName "") = Just (App (read sn :: SetName))
    | tn == typeOf (SetAge 0) = Just (App (read sn :: SetAge))
    | otherwise = Nothing

which could probably be generated using TH but I would prefer a direct solution.

Any suggestions?

{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Test where

import Data.Data
import Data.Maybe (catMaybes)

class Apply ev ag where
  apply :: ag -> ev -> ag

data Applicable a = forall e . (Show e, Read e, Typeable e, Apply e a) => App e

type Events a = [Applicable a]

fold :: Events a -> a -> a
fold [] a = a
fold ((App e):es) a = fold es $ apply a e

-----------------------------------------
-- nasty solution

serialize :: Events a -> [(TypeRep, String)]
serialize = map (\ (App e) -> (typeOf e, show e))

-- is there a way to get something like this from the `Apply` contexts?
class DeserializableFor a where
  tryDeserialize :: (TypeRep, String) -> Maybe (Applicable a)

-- because THIS is really ugly
instance DeserializableFor Person where
  tryDeserialize (tn, sn)
    | tn == typeOf (SetName "") = Just (App (read sn :: SetName))
    | tn == typeOf (SetAge 0) = Just (App (read sn :: SetAge))
    | otherwise = Nothing

deserialize :: DeserializableFor a => [(TypeRep, String)] -> Events a
deserialize = catMaybes . map tryDeserialize

--------------------------------------------------------
-- Example

data SetName = SetName String
  deriving (Show, Read, Typeable)

data SetAge = SetAge Int
  deriving (Show, Read, Typeable)

data SomeOtherEvent = SomeOtherEvent
  deriving (Show, Read, Typeable)

data Person = Person { name :: String, age :: Int }
  deriving Show

nobody :: Person
nobody = Person "" 0

instance Apply SetName Person where
  apply p (SetName n) = p { name = n }

instance Apply SetAge Person where
  apply p (SetAge a) = p { age = a }

events :: Events Person
events = [App (SetName "Mr.Wrong"), App (SetAge 42)]

serialized :: [(TypeRep, String)]
serialized = (typeOf SomeOtherEvent, show SomeOtherEvent) : serialize events

person :: Person -- is `Person {name = "Mr.Wrong", age = 42}`
person = fold (deserialize serialized) nobody

Answer 1

Below is my attempt. I wrote generic serialization using Generics and cereal. So all that's needed is to derive Generic and add empty Serialize instances. Function save first writes the type of the value, which is then checked by load. So when loading a list of events, we can check wich ones belong to the given type we want to change and drop all others (deserializeMany).

I dropped Applicable completely. Usually the problem with existential data types is that there is only a limited set of things you can do with them, so you can replace such a data type directly with the action, like a function that acts on a given object ag -> ag. See also my question Why (or why not) are existential types considered bad practice in functional programming?.

I also changed the open class of events for a given type (open in the sense any module can define additional events for an object) to a closed one - every WithEvent instance has exactly one data type that describes its possible events. This makes it somewhat easier to handle, in particular avoids some cumbersome situations where it's necessary to explicitly give types when applying events, and it's also less verbose.

{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ScopedTypeVariables,
             TypeFamilies, FlexibleContexts #-}
module Test where

import Control.Monad
import qualified Data.ByteString as BS
import Data.Maybe (catMaybes)
import Data.Typeable
import Data.Serialize
import Data.Maybe (catMaybes)
import GHC.Generics

-- * Generic serialization of events

-- ** Generic serialization of classes that know their type

save :: (Serialize a, Typeable a) => a -> Put
save x = put (show $ typeOf x) >> put x

-- | Returns 'Nothing' if the serialized event is of a different type.
-- Note that that's different from parsing error.
load :: forall a . (Serialize a, Typeable a) => Get (Maybe a)
load = do
    t <- get
    if t == show (typeRep (Proxy :: Proxy a))
      then Just <$> get
      else return Nothing -- some other type


serialize :: (Serialize a, Typeable a) => a -> BS.ByteString
serialize = runPut . save

-- | Read given events and returns the ones that apply to @a@.
deserializeMany :: (Serialize a, Typeable a) => [BS.ByteString] -> Either String [a]
deserializeMany = liftM catMaybes . mapM (runGet load)

-- ** WithEvent

class (Serialize (Event a), Typeable (Event a)) => WithEvent a where
    type family Event a
    apply :: Event a -> a -> a

fold :: (WithEvent a) => [Event a] -> a -> a
fold = flip (foldr apply)

-- * Example

-- ** Foo

data Foo = Foo

data SomeOtherEvent = SomeOtherEvent
  deriving (Show, Read, Typeable, Generic)

instance Serialize SomeOtherEvent where

instance WithEvent Foo where
    type Event Foo = SomeOtherEvent
    apply SomeOtherEvent Foo = Foo

-- ** Person

data Person = Person { name :: String, age :: Int }
  deriving Show

data PersonEvent
    = SetName String
    | SetAge Int
  deriving (Show, Read, Typeable, Generic)

instance Serialize PersonEvent where

instance WithEvent Person where
    type Event Person = PersonEvent
    apply (SetName n) p = p { name = n }
    apply (SetAge a) p = p { age = a }

-- ** Tests

nobody :: Person
nobody = Person "" 0

events :: [PersonEvent]
events = [SetName "Mr.Wrong", SetAge 42]

serialized :: [BS.ByteString]
serialized = serialize SomeOtherEvent : map serialize events

person :: Either String Person -- is `Person {name = "Mr.Wrong", age = 42}`
person = flip fold nobody <$> deserializeMany serialized