Event-sourcing and GDPR

A few weeks ago, I completed a multiple-years-old side project we had started on this website called abaks.

As a reminder, abaks is a statement reconciliation tool, which relies on a simple event system defined as follows:

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoFieldSelectors #-}

module Spec
  ( main,
    AggregateId (..),
    Events,
    CommandHandler,
    applyCommand,
    EventSourceEffect,
    withEvents,
    listAggregateIds,
    aggregateIds,
    runCommand,
    runMemoryUnsafe,
  )
where

import Control.Monad (forM_, when)
import Data.Aeson
import Data.Aeson.Text (encodeToLazyText)
import Data.Function (on)
import Data.Kind
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Time (ZonedTime)
import GHC.Generics
import Polysemy
import Polysemy.State
import Test.Hspec

-- * Entities

type CommandHandler a e = Events a -> Either e (Events a)

type Events a = [a]

-- * Use Cases

newtype AggregateId = AggregateId {getAggregateId :: Text}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (FromJSON, FromJSONKey, ToJSON, ToJSONKey)

data EventSourceEffect (eventType :: Type) (m :: Type -> Type) (a :: Type) where
  WithEvents :: AggregateId -> (Events eventType -> m (Events eventType, a)) -> EventSourceEffect eventType m a
  ListAggregateIds :: ([AggregateId] -> m a) -> EventSourceEffect eventType m a

makeSem ''EventSourceEffect

-- | Direct-return shortcut over the continuation-style 'listAggregateIds'.
aggregateIds :: forall eventType r. (Member (EventSourceEffect eventType) r) => Sem r [AggregateId]
aggregateIds = listAggregateIds @eventType pure

-- * Drivers

runEventSourceEffectMemory :: forall eventType r. InterpreterFor (EventSourceEffect eventType) r
runEventSourceEffectMemory = evalState @(Map.Map AggregateId (Events eventType)) mempty . reinterpretH go
  where
    go ::
      forall m x.
      EventSourceEffect eventType m x ->
      Tactical (EventSourceEffect eventType) m (State (Map.Map AggregateId (Events eventType)) ': r) x
    go =
      \case
        WithEvents aggregateId f -> do
          allEvents <- get @(Map.Map AggregateId (Events eventType))
          let originalAggregateEvents = Map.findWithDefault mempty aggregateId allEvents
          mf <- runTSimple $ f originalAggregateEvents
          inspector <- getInspectorT
          case inspect inspector mf of
            Nothing -> return ()
            Just (newEvents, _) -> put $ Map.insert aggregateId (originalAggregateEvents <> newEvents) allEvents
          return $ snd <$> mf
        ListAggregateIds k -> do
          allEvents <- get @(Map.Map AggregateId (Events eventType))
          mf <- runTSimple $ k (Map.keys allEvents)
          return mf

-- * Internals

applyCommand ::
  CommandHandler a e ->
  Events a ->
  Either e (Events a)
applyCommand = ($)

runCommand ::
  (Members '[EventSourceEffect eventType] r) =>
  CommandHandler eventType e ->
  AggregateId ->
  (Either e (Events eventType) -> Sem r a) ->
  Sem r a
runCommand handler aggregateId f =
  withEvents aggregateId $ \initialEvents ->
    let result = applyCommand handler initialEvents
     in (,) (either mempty id result) <$> f result

It is both simple and generic so that I can use it on other domains.

For instance, I could use it to represent the life cycle of a tour, as follows:

data TourEvent
  = TourCreated {name :: Text, start :: SpaceTime, end :: SpaceTime, groupSize :: Int}
  | BookingRequested {id :: BookingRequestId, buyer :: PersonIdentity, groupSize :: Int}
  | BookingAccepted {id :: BookingRequestId}
  deriving stock (Eq, Show, Generic)
  deriving (FromJSON, ToJSON) via (Generically TourEvent)

data SpaceTime = SpaceTime
  { place :: Text,
    at :: ZonedTime
  }
  deriving stock (Show, Generic)
  deriving (FromJSON, ToJSON) via (Generically SpaceTime)

instance Eq SpaceTime where
  (==) = (==) `on` show

newtype PersonIdentity = PersonIdentity {getPersonIdentity :: Text}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (FromJSON, ToJSON)

newtype BookingRequestId = BookingRequestId {getBookingRequestId :: Text}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (FromJSON, FromJSONKey, ToJSON, ToJSONKey)

I live in the EU, which means that I'm protected by the GDPR, but I should also support it.

Consequently, I have to be able to “remove” PII, which is the opposite of event sourcing conceptually.

There are traditionally three ways to deal with it:

• Rewrite the event stream: If you ever speak with me, it is obvious that I'm a proponent of event stream rewrite when it comes to design change; however, not only is erasing PII common, but rewriting history is costly, and it won't prevent us from forgetting some element
• Crypto-shredding: Each PII data is encrypted at rest, and we store the key outside the event stream. We don't really erase PII data; we simply erase the key, and make the data unreadable. It is costly to implement and to run, plus you have to pick a library and an algorithm strong enough to last years
• Have a dedicated PII store: We only store references to the PII in aggregate.Pick the last approach; we can start by drafting some types for the PII life cycle, as follows:

data NewPII a = NewPII
  { owner :: PIIOwner,
    value :: a
  }
  deriving stock (Eq, Show, Generic)

data StoredPII a = StoredPII
  { owner :: PIIOwner,
    key :: PIIKey
  }
  deriving stock (Eq, Show, Generic)
  deriving (FromJSON, ToJSON) via (Generically (StoredPII a))

data FetchedPII a
  = FetchedPII a
  | ForgotPII
  deriving stock (Eq, Show, Generic)

newtype PIIOwner = PIIOwner {getPIIOwner :: Text}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (FromJSON, ToJSON)

newtype PIIKey = PIIKey {getPIIKey :: Text}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (FromJSON, ToJSON)

With these types, dedicated to each phase of the event sourcing workflow, we should rework our events to wrap PII as follows:

data TourEvent' f
  = TourCreated' {name :: Text, start :: SpaceTime, end :: SpaceTime, groupSize :: Int}
  | BookingRequested' {id :: BookingRequestId, buyer :: f PersonIdentity, groupSize :: Int}
  | BookingAccepted' {id :: BookingRequestId}

Along the way, f will be replaced by NewPII, StoredPII, and FetchedPII.

We can create a PII-aware effect as follows:

data PIIEventSourceEffect (eventType :: (Type -> Type) -> Type) (m :: Type -> Type) (a :: Type) where
  WithPIIEvents ::
    AggregateId ->
    (Events (eventType FetchedPII) -> m (Events (eventType NewPII), a)) ->
    PIIEventSourceEffect eventType m a
  ListPIIAggregateIds ::
    ([AggregateId] -> m a) ->
    PIIEventSourceEffect eventType m a

makeSem ''PIIEventSourceEffect

While this constraint forces us to do a large design work, it has the virtue of strong-typing events origin.

Before jumping on the implementation of an interpreter, we should also create an effect to store and fetch from a PII store, defined as follows:

data PIIStoreEffect (m :: Type -> Type) (a :: Type) where
  SavePII ::
    forall f a m.
    f NewPII ->
    PIIStoreEffect m (f StoredPII)
  FetchPII ::
    forall f a m.
    f StoredPII ->
    PIIStoreEffect m (f FetchedPII)

makeSem ''PIIStoreEffect

We are all set to write our first interpreter for PIIEventSourceEffect, defined as follows:

runEventSourcePII ::
  forall eventType r.
  (Members '[PlainEventSourceEffect (eventType StoredPII), PIIStoreEffect] r, Transformable eventType) =>
  InterpreterFor (PIIEventSourceEffect eventType) r
runEventSourcePII =
  interpretH $
    \case
      WithPIIEvents aggregateId f -> do
        withPlainEvents @(eventType StoredPII) aggregateId $ \storedEvents -> do
          fResult <- runTSimple . f =<< mapM fetchPII storedEvents
          ins <- getInspectorT
          s <- getInitialStateT
          let (newEvents, result) = fromMaybe (error "TODO") $ inspect ins fResult
          savedEvents <- mapM savePII newEvents
          pure (savedEvents, result <$ s)
      ListPIIAggregateIds k -> do
        mf <- listPlainAggregateIds @(eventType StoredPII) $ runTSimple . k
        return mf

The idea is simple: rely on PlainEventSourceEffect, which only deals with eventType StoredPII, and add a thin wrapper to go in and out of PIIStoreEffect.

Usually, key-value stores are simple; this one is an exception to the rule because it has to do the serialization work, including going through the events' structure.

We can naively define it as follows:

type PIIMemoryStore = Map.Map PIIOwner (Map.Map PIIKey ByteString)

runPIIStoreMemory :: forall r. InterpreterFor PIIStoreEffect r
runPIIStoreMemory = evalState @PIIMemoryStore mempty . reinterpret go
  where
    go ::
      forall rInitial x.
      PIIStoreEffect (Sem rInitial) x ->
      Sem (State PIIMemoryStore : r) x
    go =
      \case
        SavePII x -> do
          let store ::
                forall a.
                (Aeson.ToJSON a) =>
                NewPII a ->
                Sem (State PIIMemoryStore ': r) (StoredPII a)
              store NewPII {..} = do
                ownerPiis <- gets @PIIMemoryStore $ Map.findWithDefault mempty owner
                let serialized = Aeson.encode value
                    key = PIIKey $ T.pack $ show $ Map.size ownerPiis
                modify @PIIMemoryStore $ Map.insert owner $ Map.insert key serialized ownerPiis
                return $ StoredPII {..}
          transformM store x
        FetchPII x -> do
          let fetch ::
                forall a.
                (Aeson.FromJSON a) =>
                StoredPII a -> Sem (State PIIMemoryStore ': r) (FetchedPII a)
              fetch StoredPII {..} = do
                gets @PIIMemoryStore $ \piis ->
                  maybe ForgotPII FetchedPII $
                    Aeson.decode @a
                      =<< Map.lookup key (Map.findWithDefault mempty owner piis)
          transformM fetch x

There are many things preventing this code from compiling. First, there is transformM which is not defined.

transformM is weird; it is a mix of a natural transformation and traverse. It can be drafted as follows:

transformM :: (Applicative m) => (forall a. f a -> m (g a)) -> s f -> m (s g)

In plain English: we expect a function that transforms all values wrapped by f to a value wrapped by g, emitting an effect m; and a structure s with values wrapped in f to get the same structure with values wrapped in g inside and effect m.

It is not enough; get and store except aeson constraints we have to enrich transformM with, as follows:

transformM :: (Applicative m) => (forall a. (Aeson.ToJSON a, Aeson.FromJSON a) => f a -> m (g a)) -> s f -> m (s g)

Sadly, this function cannot be defined for every type; we have to turn it into the following type class:

class Transformable (s :: (Type -> Type) -> Type) where
  transformM ::
    (Applicative m) =>
    (forall a. (Aeson.ToJSON a, Aeson.FromJSON a) => f a -> m (g a)) -> s f -> m (s g)

We should also propagate the constraint to PIIStoreEffect operations, as follows:

data PIIStoreEffect (m :: Type -> Type) (a :: Type) where
  SavePII ::
    forall f a m.
    (Transformable f) =>
    f NewPII ->
    PIIStoreEffect m (f StoredPII)
  FetchPII ::
    forall f a m.
    (Transformable f) =>
    f StoredPII ->
    PIIStoreEffect m (f FetchedPII)

makeSem ''PIIStoreEffect

Similarly, our target, eventType, should also be Transformable, as follows:

runEventSourcePII ::
  forall eventType r.
  (Members '[PlainEventSourceEffect (eventType StoredPII), PIIStoreEffect] r, Transformable eventType) =>
  InterpreterFor (PIIEventSourceEffect eventType) r
runEventSourcePII =
  interpretH $
    \case
      WithPIIEvents aggregateId f -> do
        withPlainEvents @(eventType StoredPII) aggregateId $ \storedEvents -> do
          fResult <- runTSimple . f =<< mapM fetchPII storedEvents
          ins <- getInspectorT
          s <- getInitialStateT
          let (newEvents, result) = fromMaybe (error "TODO") $ inspect ins fResult
          savedEvents <- mapM savePII newEvents
          pure (savedEvents, result <$ s)
      ListPIIAggregateIds k -> do
        mf <- listPlainAggregateIds @(eventType StoredPII) $ runTSimple . k
        return mf

To end up this log on a practical example, implementing an instance is as simple as the following snippet:

instance Transformable TourEvent' where
  transformM f =
    \case
      TourCreated' {..} ->
        pure TourCreated' {..}
      BookingRequested' {..} ->
        BookingRequested' id <$> f buyer <*> pure groupSize
      BookingAccepted' {..} ->
        pure BookingAccepted' {..}

It should be possible to derive instances, but it goes beyond this already long log.