packages feed

eventium-core (empty) → 0.1.0

raw patch · 20 files changed

+1524/−0 lines, 20 filesdep +HUnitdep +aesondep +base

Dependencies added: HUnit, aeson, base, containers, contravariant, hspec, http-api-data, path-pieces, template-haskell, text, transformers, uuid, x-sum-type-boilerplate

Files

+ CHANGELOG.md view
+ LICENSE.md view
@@ -0,0 +1,21 @@+Copyright (c) 2025 Alexander Sidorenko+Copyright (c) 2016-2017 David Reaver+++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,90 @@+# Eventium Core++Core abstractions and utilities for building event sourcing systems in Haskell.++## Overview++`eventium-core` is the foundational package of the Eventium event sourcing framework. It provides all the essential abstractions, interfaces, and utilities needed to build event-sourced applications with CQRS patterns.++## Key Components++### Event Store (`Eventium.Store.Class`)+- **`EventStoreReader`** - Read events from streams (versioned and global)+- **`EventStoreWriter`** - Append events with optimistic concurrency control+- **`StreamEvent`** - Event metadata wrapper with stream keys and positions++### Projection (`Eventium.Projection`)+Pure event fold for rebuilding state from events. Used for both domain aggregates (write model) and read models (query side).++```haskell+data Projection state event = Projection+  { projectionSeed :: state+  , projectionEventHandler :: state -> event -> state+  }+```++### Command Handler (`Eventium.CommandHandler`)+Implements the aggregate pattern from DDD/Event Sourcing. Processes commands, validates against current state, and emits events.++```haskell+data CommandHandler state event command = CommandHandler+  { commandHandlerHandler :: state -> command -> [event]+  , commandHandlerProjection :: Projection state event+  }+```++### Process Manager (`Eventium.ProcessManager`)+Coordinates long-running business processes across multiple aggregates. Implements the Saga pattern for complex workflows.++### Read Model (`Eventium.ReadModel.Class`)+Builds denormalized views optimized for queries. Tracks processed events for eventual consistency with the write side.++### Serializer (`Eventium.Serializer`)+Type-safe event serialization/deserialization with JSON support and Template Haskell utilities for automatic boilerplate generation.++### Template Haskell Utilities (`Eventium.TH`)+- **`deriveJSON`** - Generate JSON instances+- **`deriveSumTypeSerializer`** - Generate serializers for sum types (event polymorphism)+- **`makeProjection`** - Generate projection boilerplate++## Features++- ✅ Type-safe event sourcing abstractions+- ✅ Optimistic concurrency control with `ExpectedPosition`+- ✅ CQRS pattern support (command/query separation)+- ✅ Process Manager (Saga) pattern+- ✅ Projection caching for performance+- ✅ Template Haskell for reducing boilerplate+- ✅ Storage backend agnostic (memory, SQL, NoSQL)++## Usage++Add `eventium-core` to your package dependencies:++```yaml+dependencies:+  - eventium-core+```++Then choose a storage backend:+- `eventium-memory` - In-memory (development/testing)+- `eventium-sqlite` - SQLite (single-process apps)+- `eventium-postgresql` - PostgreSQL (production systems)++## Design Principles++1. **Type Safety** - Phantom types prevent mixing concerns+2. **Functional Purity** - Projections are pure folds+3. **Abstraction** - Backend-agnostic core types+4. **CQRS** - Clear command/query separation+5. **Standard Patterns** - Aggregates, Sagas, Read Models++## Documentation++- [Main README](../README.md) - Project overview+- [Design Documentation](../DESIGN.md) - Detailed architecture+- [Examples](../examples/) - Working applications++## License++MIT - see [LICENSE.md](LICENSE.md)
+ eventium-core.cabal view
@@ -0,0 +1,105 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           eventium-core+version:        0.1.0+synopsis:       Core module for eventium+description:    Eventium-core provides the core abstractions and utilities for building event sourcing systems in Haskell.+                It includes event store interfaces, command handlers, projections, read models, process managers, and+                Template Haskell utilities for generating boilerplate code. This is the foundational package that all+                other Eventium modules build upon.+category:       Database,Eventsourcing+stability:      experimental+homepage:       https://github.com/aleks-sidorenko/eventium#readme+bug-reports:    https://github.com/aleks-sidorenko/eventium/issues+maintainer:     Alexander Sidorenko+license:        MIT+license-file:   LICENSE.md+build-type:     Simple+extra-source-files:+    CHANGELOG.md+    README.md++source-repository head+  type: git+  location: https://github.com/aleks-sidorenko/eventium++library+  exposed-modules:+      Eventium+      Eventium.CommandHandler+      Eventium.EventBus+      Eventium.ProcessManager+      Eventium.Projection+      Eventium.ProjectionCache.Types+      Eventium.ReadModel.Class+      Eventium.Serializer+      Eventium.Store.Class+      Eventium.Store.Queries+      Eventium.TH+      Eventium.TH.Projection+      Eventium.TH.SumTypeSerializer+      Eventium.UUID+  other-modules:+      Paths_eventium_core+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson >=1.5 && <2.3+    , base >=4.9 && <5+    , containers >=0.6 && <0.8+    , contravariant >=1.5 && <1.6+    , http-api-data >=0.4 && <0.7+    , path-pieces >=0.2 && <0.3+    , template-haskell >=2.16 && <2.22+    , text >=1.2 && <2.2+    , transformers >=0.5 && <0.7+    , uuid >=1.3 && <1.4+    , x-sum-type-boilerplate >=0.1 && <0.2+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Eventium.SerializerSpec+      Eventium+      Eventium.CommandHandler+      Eventium.EventBus+      Eventium.ProcessManager+      Eventium.Projection+      Eventium.ProjectionCache.Types+      Eventium.ReadModel.Class+      Eventium.Serializer+      Eventium.Store.Class+      Eventium.Store.Queries+      Eventium.TH+      Eventium.TH.Projection+      Eventium.TH.SumTypeSerializer+      Eventium.UUID+      Paths_eventium_core+  hs-source-dirs:+      tests+      src+  ghc-options: -Wall+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      HUnit+    , aeson >=1.5 && <2.3+    , base >=4.9 && <5+    , containers >=0.6 && <0.8+    , contravariant >=1.5 && <1.6+    , hspec+    , http-api-data >=0.4 && <0.7+    , path-pieces >=0.2 && <0.3+    , template-haskell >=2.16 && <2.22+    , text >=1.2 && <2.2+    , transformers >=0.5 && <0.7+    , uuid >=1.3 && <1.4+    , x-sum-type-boilerplate >=0.1 && <0.2+  default-language: Haskell2010
+ src/Eventium.hs view
@@ -0,0 +1,14 @@+module Eventium+  ( module X,+  )+where++import Eventium.CommandHandler as X+import Eventium.EventBus as X+import Eventium.ProcessManager as X+import Eventium.Projection as X+import Eventium.ProjectionCache.Types as X+import Eventium.ReadModel.Class as X+import Eventium.Serializer as X+import Eventium.Store.Class as X+import Eventium.UUID as X
+ src/Eventium/CommandHandler.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE RecordWildCards #-}++-- | Defines a Command Handler type.+module Eventium.CommandHandler+  ( CommandHandler (..),+    allCommandHandlerStates,+    applyCommandHandler,+    serializedCommandHandler,+  )+where++import Data.Foldable (foldl')+import Data.List (scanl')+import Eventium.Projection+import Eventium.Serializer+import Eventium.Store.Class+import Eventium.UUID++-- | An 'CommandHandler' is a combination of a 'Projection' and a function to+-- validate commands against that 'Projection'. When using a command handler 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 CommandHandler state event command+  = CommandHandler+  { commandHandlerHandler :: state -> command -> [event],+    commandHandlerProjection :: Projection state event+  }++-- | Given a list commands, produce all of the states the command handler's+-- projection sees. This is useful for unit testing a 'CommandHandler'.+allCommandHandlerStates ::+  CommandHandler state event command ->+  [command] ->+  [state]+allCommandHandlerStates (CommandHandler commandHandler (Projection seed eventHandler)) =+  scanl' go seed+  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 'CommandHandler' command to it. If the command succeeds, then this+-- saves the events back to the store as well.+applyCommandHandler ::+  (Monad m) =>+  VersionedEventStoreWriter m event ->+  VersionedEventStoreReader m event ->+  CommandHandler state event command ->+  UUID ->+  command ->+  m [event]+applyCommandHandler writer reader (CommandHandler handler proj) uuid command = do+  StreamProjection {..} <- getLatestStreamProjection reader (versionedStreamProjection uuid proj)+  let events = handler streamProjectionState command+  mError <- storeEvents writer uuid (ExactPosition streamProjectionPosition) events+  case mError of+    Left err -> error $ "TODO: Create CommandHandler restart logic. " ++ show err+    Right _ -> return events++-- | Use a pair of 'Serializer's to wrap a 'CommandHandler' with event type @event@+-- and command type @command@ so it uses the @serializedEvent@ and+-- @serializedCommand@ types.+serializedCommandHandler ::+  CommandHandler state event command ->+  Serializer event serializedEvent ->+  Serializer command serializedCommand ->+  CommandHandler state serializedEvent serializedCommand+serializedCommandHandler (CommandHandler commandHandler projection) eventSerializer commandSerializer =+  CommandHandler serializedHandler serializedProjection'+  where+    serializedProjection' = serializedProjection projection eventSerializer+    -- Try to deserialize the command and apply the handler. If we can't+    -- deserialize, then just return no events. We also need to serialize the+    -- events after of course.+    serializedHandler state = map (serialize eventSerializer) . maybe [] (commandHandler state) . deserialize commandSerializer
+ src/Eventium/EventBus.hs view
@@ -0,0 +1,45 @@+module Eventium.EventBus+  ( synchronousEventBusWrapper,+    storeAndPublishEvents,+  )+where++import Eventium.Store.Class+import Eventium.UUID++-- | This function wraps an event store by sending events to event handlers+-- after running 'storeEvents'. This is useful to quickly wire up event+-- handlers in your application (like read models or process managers), and it+-- is also useful for integration testing along with an in-memory event store.+synchronousEventBusWrapper ::+  (Monad m) =>+  VersionedEventStoreWriter m event ->+  [VersionedEventStoreWriter m event -> UUID -> event -> m ()] ->+  VersionedEventStoreWriter m event+synchronousEventBusWrapper writer handlers = wrappedStore+  where+    -- NB: We need to use recursive let bindings so we can put wrappedStore+    -- inside the event handlers+    handlers' = map ($ wrappedStore) handlers+    wrappedStore = EventStoreWriter $ storeAndPublishEvents writer handlers'++-- | Stores events in the store and then publishes them to the event handlers.+-- This is used in the 'synchronousEventBusWrapper'.+storeAndPublishEvents ::+  (Monad m) =>+  VersionedEventStoreWriter m event ->+  [UUID -> event -> m ()] ->+  UUID ->+  ExpectedPosition EventVersion ->+  [event] ->+  m (Either (EventWriteError EventVersion) EventVersion)+storeAndPublishEvents store handlers uuid expectedVersion events = do+  result <- storeEvents store uuid expectedVersion events+  case result of+    Left err -> return $ Left err+    Right vers -> do+      -- NB: If a handler stores events, then its events will be published+      -- before the events of the next handler. That is, we will be storing+      -- events generated by handlers in depth-first order.+      mapM_ (\handler -> mapM_ (handler uuid) events) handlers+      return $ Right vers
+ src/Eventium/ProcessManager.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}++module Eventium.ProcessManager+  ( ProcessManager (..),+    ProcessManagerCommand (..),+    applyProcessManagerCommandsAndEvents,+  )+where++import Control.Monad (forM_, void)+import Eventium.CommandHandler+import Eventium.Projection+import Eventium.Store.Class+import Eventium.UUID++-- | A 'ProcessManager' manages interaction between event streams. It works by+-- listening to events on an event bus and applying events to its internal+-- 'Projection' (see 'applyProcessManagerCommandsAndEvents'). Then, pending+-- commands and events are plucked off of that Projection and applied to the+-- appropriate 'CommandHandler' or Projections in other streams.+data ProcessManager state event command+  = ProcessManager+  { processManagerProjection :: Projection state (VersionedStreamEvent event),+    processManagerPendingCommands :: state -> [ProcessManagerCommand event command],+    processManagerPendingEvents :: state -> [StreamEvent UUID () event]+  }++-- | This is a @command@ along with the UUID of the target 'CommandHandler', as+-- well as the 'CommandHandler' type. Note that this uses an existential type+-- to hide the @state@ type parameter on the CommandHandler.+data ProcessManagerCommand event command+  = forall state. ProcessManagerCommand+  { processManagerCommandTargetId :: UUID,+    processManagerCommandCommandHandler :: CommandHandler state event command,+    processManagerCommandCommand :: command+  }++instance (Show command, Show event) => Show (ProcessManagerCommand event command) where+  show (ProcessManagerCommand uuid _ command) =+    "ProcessManagerCommand{processManagerCommandCommandHandlerId = "+      ++ show uuid+      ++ ", processManagerCommandCommand = "+      ++ show command+      ++ "}"++-- | Plucks the pending commands and events off of the process manager's state+-- and applies them to the appropriate locations in the event store.+applyProcessManagerCommandsAndEvents ::+  (Monad m) =>+  ProcessManager state event command ->+  VersionedEventStoreWriter m event ->+  VersionedEventStoreReader m event ->+  state ->+  m ()+applyProcessManagerCommandsAndEvents ProcessManager {..} writer reader state = do+  forM_ (processManagerPendingCommands state) $ \(ProcessManagerCommand targetId commandHandler command) ->+    void $ applyCommandHandler writer reader commandHandler targetId command+  forM_ (processManagerPendingEvents state) $ \(StreamEvent projectionId () event) ->+    storeEvents writer projectionId AnyPosition [event]
+ src/Eventium/Projection.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE RecordWildCards #-}++module Eventium.Projection+  ( Projection (..),+    latestProjection,+    allProjections,+    StreamProjection (..),+    VersionedStreamProjection,+    GlobalStreamProjection,+    streamProjection,+    versionedStreamProjection,+    globalStreamProjection,+    streamProjectionEventHandler,+    getLatestStreamProjection,+    serializedProjection,+    projectionMapMaybe,+  )+where++import Data.Foldable (foldl')+import Data.Functor.Contravariant+import Data.List (scanl')+import Eventium.Serializer+import Eventium.Store.Class+import Eventium.UUID++-- | A 'Projection' is a piece of @state@ that is constructed only from+-- @event@s. A Projection is how you reconstruct event sourced state from the+-- ordered stream of events that constitute that state. The "seed" of a+-- Projection is the initial state before any events are applied. The event+-- handler for a projection is the function that actually modifies state based+-- on the given event.+data Projection state event+  = Projection+  { -- | Initial state of a projection+    projectionSeed :: state,+    -- | The function that applies and event to the current state, producing a+    -- new state.+    projectionEventHandler :: state -> event -> state+  }++instance Contravariant (Projection state) where+  contramap f (Projection seed handler) = Projection seed handler'+    where+      handler' state event = handler state (f event)++-- | Computes the latest state of a 'Projection' from some events.+latestProjection :: (Foldable t) => Projection state event -> t event -> state+latestProjection (Projection seed handler) = foldl' handler seed++-- | Given a list of events, produce all the Projections that were ever+-- produced. Just a 'scanl' using 'projectionEventHandler'. This function is+-- useful for testing 'Projection's; you can easily assert that all the states+-- of a Projection are valid given a list of events.+allProjections :: Projection state event -> [event] -> [state]+allProjections (Projection seed handler) = scanl' handler seed++-- | A 'StreamProjection' is a 'Projection' that has been constructed from+-- events from a particular event stream. This is useful when we want to cache+-- the resulting state and also keep track of what part of the stream the state+-- is caught up to.+data StreamProjection key position state event+  = StreamProjection+  { streamProjectionKey :: !key,+    streamProjectionPosition :: !position,+    streamProjectionProjection :: !(Projection state event),+    streamProjectionState :: !state+  }++type VersionedStreamProjection = StreamProjection UUID EventVersion++type GlobalStreamProjection state event = StreamProjection () SequenceNumber state (VersionedStreamEvent event)++-- | Initialize a 'StreamProjection' with a 'Projection', key, and order key.+streamProjection ::+  key ->+  position ->+  Projection state event ->+  StreamProjection key position state event+streamProjection key position projection@Projection {..} =+  StreamProjection key position projection projectionSeed++-- | Initialize a 'VersionedStreamProjection'.+versionedStreamProjection ::+  UUID ->+  Projection state event ->+  VersionedStreamProjection state event+versionedStreamProjection uuid = streamProjection uuid (-1)++-- | Initialize a 'GlobalStreamProjection'.+globalStreamProjection ::+  Projection state (VersionedStreamEvent event) ->+  GlobalStreamProjection state event+globalStreamProjection = streamProjection () 0++-- | Apply an event to the 'StreamProjection'. NOTE: There is no guarantee that+-- the order key for the event is greater than the current order key in the+-- 'StreamProjection'. This function will simply update the 'StreamProjection'+-- to use the order key of the event.+streamProjectionEventHandler ::+  StreamProjection key position state event ->+  StreamEvent eventKey position event ->+  StreamProjection key position state event+streamProjectionEventHandler StreamProjection {..} event =+  let Projection {..} = streamProjectionProjection+      position' = streamEventPosition event+      state' = projectionEventHandler streamProjectionState (streamEventEvent event)+   in StreamProjection streamProjectionKey position' streamProjectionProjection state'++-- | Gets the latest projection from a store by querying events from the latest+-- order key and then applying the events using the Projection's event handler.+getLatestStreamProjection ::+  (Monad m, Num position) =>+  EventStoreReader key position m (StreamEvent key position event) ->+  StreamProjection key position state event ->+  m (StreamProjection key position state event)+getLatestStreamProjection (EventStoreReader getEvents') projection@StreamProjection {..} = do+  events <- getEvents' (eventsStartingAt streamProjectionKey $ streamProjectionPosition + 1)+  return $ foldl' streamProjectionEventHandler projection events++-- | Use a 'Serializer' to wrap a 'Projection' with event type @event@ so it+-- uses the @serialized@ type.+serializedProjection ::+  Projection state event ->+  Serializer event serialized ->+  Projection state serialized+serializedProjection proj Serializer {..} = projectionMapMaybe deserialize proj++-- | Transform a 'Projection' when you only have a partial relationship between+-- the source event type and the target event type.+projectionMapMaybe ::+  (eventB -> Maybe eventA) ->+  Projection state eventA ->+  Projection state eventB+projectionMapMaybe f (Projection seed handler) = Projection seed handler'+  where+    handler' state = maybe state (handler state) . f
+ src/Eventium/ProjectionCache/Types.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Eventium.ProjectionCache.Types+  ( ProjectionCache (..),+    VersionedProjectionCache,+    GlobalStreamProjectionCache,+    runProjectionCacheUsing,+    serializedProjectionCache,+    getLatestVersionedProjectionWithCache,+    getLatestGlobalProjectionWithCache,+    updateProjectionCache,+    updateGlobalProjectionCache,+  )+where++import Eventium.Projection+import Eventium.Serializer+import Eventium.Store.Class+import Eventium.UUID++-- | A 'ProjectionCache' caches snapshots of 'Projection's in event streams.+-- This is useful if your event streams are very large. This cache operates on+-- some 'Monad' @m@ and stores the 'Projection' state of type @serialized@.+--+-- At its core, this is essentially just a key-value store with knowledge of+-- the stream 'UUID' and 'EventVersion'. It is recommended to use the other+-- helper functions in this module to interpret the stored values using a+-- 'Projection'.+--+-- The @key@ and @position@ type parameters are polymorphic so we can abstract+-- over a cache for individual event streams, and a cache for globally ordered+-- streams.+data ProjectionCache key position serialized m+  = ProjectionCache+  { -- | Stores the state for a projection at a given @key@ and @position@.+    -- This is pretty unsafe, because there is no guarantee what is stored is+    -- actually derived from the events in the stream. Consider using+    -- 'updateProjectionCache'.+    storeProjectionSnapshot :: key -> position -> serialized -> m (),+    -- | Loads the latest projection state from the cache.+    loadProjectionSnapshot :: key -> m (Maybe (position, serialized))+  }++-- | Type synonym for a 'ProjectionCache' used on individual event streams.+type VersionedProjectionCache serialized m = ProjectionCache UUID EventVersion serialized m++-- | Type synonym for a 'ProjectionCache' that is used in conjunction with a+-- 'GlobalStreamEventStore'.+type GlobalStreamProjectionCache key serialized m = ProjectionCache key SequenceNumber serialized m++-- | Changes the monad a 'ProjectionCache' runs in. This is useful to run the+-- cache in another 'Monad' while forgetting the original 'Monad'.+runProjectionCacheUsing ::+  (Monad m, Monad mstore) =>+  (forall a. mstore a -> m a) ->+  ProjectionCache key position serialized mstore ->+  ProjectionCache key position serialized m+runProjectionCacheUsing runCache ProjectionCache {..} =+  ProjectionCache+    { storeProjectionSnapshot = \uuid version state -> runCache $ storeProjectionSnapshot uuid version state,+      loadProjectionSnapshot = runCache . loadProjectionSnapshot+    }++-- | Wraps a 'ProjectionCache' and transparently serializes/deserializes events for+-- you. Note that in this implementation deserialization errors when using+-- 'getEvents' are simply ignored (the event is not returned).+serializedProjectionCache ::+  (Monad m) =>+  Serializer state serialized ->+  ProjectionCache key position serialized m ->+  ProjectionCache key position state m+serializedProjectionCache Serializer {..} ProjectionCache {..} =+  ProjectionCache storeProjectionSnapshot' loadProjectionSnapshot'+  where+    storeProjectionSnapshot' uuid version = storeProjectionSnapshot uuid version . serialize+    loadProjectionSnapshot' uuid = do+      mState <- loadProjectionSnapshot uuid+      return $ mState >>= traverse deserialize++-- | Like 'getLatestVersionedProjection', but uses a 'ProjectionCache' if it contains+-- more recent state.+getLatestVersionedProjectionWithCache ::+  (Monad m) =>+  VersionedEventStoreReader m event ->+  VersionedProjectionCache state m ->+  VersionedStreamProjection state event ->+  m (VersionedStreamProjection state event)+getLatestVersionedProjectionWithCache store cache projection =+  getLatestProjectionWithCache' cache projection (streamProjectionKey projection) >>= getLatestStreamProjection store++-- | Like 'getLatestGlobalProjection', but uses a 'ProjectionCache' if it+-- contains more recent state.+getLatestGlobalProjectionWithCache ::+  (Monad m) =>+  GlobalEventStoreReader m event ->+  GlobalStreamProjectionCache key state m ->+  GlobalStreamProjection state event ->+  key ->+  m (GlobalStreamProjection state event)+getLatestGlobalProjectionWithCache store cache projection key =+  getLatestProjectionWithCache' cache projection key >>= getLatestStreamProjection store++getLatestProjectionWithCache' ::+  (Monad m, Ord position) =>+  ProjectionCache key position state m ->+  StreamProjection projKey position state event ->+  key ->+  m (StreamProjection projKey position state event)+getLatestProjectionWithCache' cache projection key = do+  mLatestState <- loadProjectionSnapshot cache key+  let mkProjection' (position, state) =+        if position > streamProjectionPosition projection+          then+            projection+              { streamProjectionPosition = position,+                streamProjectionState = state+              }+          else projection+  return $ maybe projection mkProjection' mLatestState++-- | Loads the latest projection state from the cache/store and stores this+-- value back into the projection cache.+updateProjectionCache ::+  (Monad m) =>+  VersionedEventStoreReader m event ->+  VersionedProjectionCache state m ->+  VersionedStreamProjection state event ->+  m ()+updateProjectionCache reader cache projection = do+  StreamProjection {..} <- getLatestVersionedProjectionWithCache reader cache projection+  storeProjectionSnapshot cache streamProjectionKey streamProjectionPosition streamProjectionState++-- | Analog of 'updateProjectionCache' for a 'GlobalStreamProjectionCache'.+updateGlobalProjectionCache ::+  (Monad m) =>+  GlobalEventStoreReader m event ->+  GlobalStreamProjectionCache key state m ->+  GlobalStreamProjection state event ->+  key ->+  m ()+updateGlobalProjectionCache reader cache projection key = do+  StreamProjection {..} <- getLatestGlobalProjectionWithCache reader cache projection key+  storeProjectionSnapshot cache key streamProjectionPosition streamProjectionState
+ src/Eventium/ReadModel/Class.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Eventium.ReadModel.Class+  ( ReadModel (..),+    runPollingReadModel,+  )+where++import Control.Concurrent (threadDelay)+import Control.Monad (forever)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Eventium.Store.Class++data ReadModel model serialized m+  = ReadModel+  { readModelModel :: model,+    readModelLatestAppliedSequence :: model -> m SequenceNumber,+    readModelHandleEvents :: model -> [GlobalStreamEvent serialized] -> m ()+  }++type PollingPeriodSeconds = Double++runPollingReadModel ::+  (MonadIO m, Monad mstore) =>+  ReadModel model serialized m ->+  GlobalEventStoreReader mstore serialized ->+  (forall a. mstore a -> m a) ->+  PollingPeriodSeconds ->+  m ()+runPollingReadModel ReadModel {..} globalReader runStore waitSeconds = forever $ do+  -- Get new events starting from latest applied sequence number+  latestSeq <- readModelLatestAppliedSequence readModelModel+  newEvents <- runStore $ getEvents globalReader (eventsStartingAt () $ latestSeq + 1)++  -- Handle the new events+  readModelHandleEvents readModelModel newEvents++  -- Wait before running again+  liftIO $ threadDelay $ ceiling (waitSeconds * 1000000) -- threadDelay accepts microseconds++-- data EventHandler m serialized = forall event. (Serializable event serialized, Monad m) => EventHandler (event -> m ())++-- combineHandlers :: (Monad m) => [EventHandler m serialized] -> (serialized -> m ())+-- combineHandlers handlers event = mapM_ ($ event) (mkHandler <$> handlers)++-- mkHandler :: EventHandler m serialized -> (serialized -> m ())+-- mkHandler (EventHandler handler) event = maybe (return ()) handler (deserialize event)
+ src/Eventium/Serializer.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++module Eventium.Serializer+  ( -- * Class+    Serializer (..),+    simpleSerializer,+    composeSerializers,++    -- * Common serializers+    idSerializer,+    traverseSerializer,+    jsonSerializer,+    jsonTextSerializer,+    dynamicSerializer,++    -- * Sum types+    EventSumType (..),+    eventSumTypeSerializer,+  )+where++import Control.Applicative ((<|>))+import Data.Aeson+import Data.Dynamic+import Data.Maybe (fromMaybe)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import Data.Typeable (typeOf)+import GHC.Generics++-- | A 'Serializer' describes the injective conversion between types @a@ and+-- @b@. In plain English, this means that you can go from @a@ to @b@, and you+-- can 'Maybe' go from @b@ back to @a@. This is often used to serialize events+-- to an event store, and then deserialize them back.+data Serializer a b+  = Serializer+  { serialize :: a -> b,+    deserialize :: b -> Maybe a,+    -- | Deserialize with additional information on failure+    deserializeEither :: b -> Either String a+  }++-- | Simple constructor to just use 'deserialize' to construct+-- 'deserializeEither'.+simpleSerializer ::+  (a -> b) ->+  (b -> Maybe a) ->+  Serializer a b+simpleSerializer serialize' deserialize' =+  Serializer+    { serialize = serialize',+      deserialize = deserialize',+      deserializeEither = maybe (Left "Serializable: Failed to deserialize") Right . deserialize'+    }++-- | Apply an intermediate 'Serializer' to a serializer to go from type @a@ to+-- @c@ with @b@ in the middle. Note that with deserializing, if the conversion+-- from @c@ to @b@ or from @b@ to @a@ fails, the whole deserialization fails.+composeSerializers :: Serializer a b -> Serializer b c -> Serializer a c+composeSerializers serializer1 serializer2 = Serializer serialize' deserialize' deserializeEither'+  where+    serialize' = serialize serializer2 . serialize serializer1+    deserialize' x = deserialize serializer2 x >>= deserialize serializer1+    deserializeEither' x = deserializeEither serializer2 x >>= deserializeEither serializer1++-- | Simple "serializer" using 'id'. Useful for when an API requires a+-- serializer but you don't need to actually change types.+idSerializer :: Serializer a a+idSerializer = simpleSerializer id Just++-- | Uses 'Traversable' to wrap a 'Serializer'.+traverseSerializer ::+  (Traversable t) =>+  Serializer a b ->+  Serializer (t a) (t b)+traverseSerializer Serializer {..} =+  Serializer serialize' deserialize' deserializeEither'+  where+    serialize' = fmap serialize+    deserialize' = traverse deserialize+    deserializeEither' = traverse deserializeEither++-- | A 'Serializer' for aeson 'Value's.+jsonSerializer :: (ToJSON a, FromJSON a) => Serializer a Value+jsonSerializer =+  Serializer+    { serialize = toJSON,+      deserialize = \x ->+        case fromJSON x of+          Success a -> Just a+          Error _ -> Nothing,+      deserializeEither = \x ->+        case fromJSON x of+          Success a -> Right a+          Error e -> Left e+    }++-- | A 'Serializer' to convert JSON to/from lazy text. Useful for Sql event+-- stores that store JSON values as text.+jsonTextSerializer :: (ToJSON a, FromJSON a) => Serializer a TL.Text+jsonTextSerializer =+  Serializer+    { serialize = TLE.decodeUtf8 . encode,+      deserialize = decode . TLE.encodeUtf8,+      deserializeEither = eitherDecode . TLE.encodeUtf8+    }++-- | A 'Serializer' for 'Dynamic' values using 'toDyn' and 'fromDynamic'.+dynamicSerializer :: (Typeable a) => Serializer a Dynamic+dynamicSerializer = simpleSerializer toDyn fromDynamic++-- | A 'Serializer' from one 'EventSumType' instance to another. WARNING: If+-- not all events in the source 'EventSumType' are in the @serialized@+-- 'EventSumType', then this function will be partial!+eventSumTypeSerializer :: (Typeable a, EventSumType a, EventSumType b) => Serializer a b+eventSumTypeSerializer = simpleSerializer serialize' deserialize'+  where+    serialize' event =+      fromMaybe+        (error $ "Failure in eventSumTypeSerializer. Can't serialize " ++ show (typeOf event))+        (eventFromDyn $ eventToDyn event)+    deserialize' = eventFromDyn . eventToDyn++-- | This is a type class for serializing sum types of events to 'Dynamic'+-- without the associated constructor. This is useful when transforming between+-- two sum types of events. A common pattern is to put all the events in an+-- application in one big event sum type, and then have a smaller sum type for+-- each 'Projection'. Then, you can use 'eventSumTypeSerializer' to transform+-- between the two.+--+-- It is meant to be derived with 'Generic'. For example:+--+-- @+--    data EventA = EventA deriving (Show)+--    data EventB = EventB deriving (Show)+--    data EventC = EventC deriving (Show)+--+--    data AllEvents+--      = AllEventsEventA EventA+--      | AllEventsEventB EventB+--      | AllEventsEventC EventC+--      deriving (Show, Generic)+--+--    instance EventSumType AllEvents+--+--    data MyEvents+--      = MyEventsEventA EventA+--      | MyEventsEventB EventB+--      deriving (Show, Generic)+--+--    instance EventSumType MyEvents+-- @+--+-- Now we can serialize to 'Dynamic' without a constructor tag:+--+-- >>> eventToDyn (MyEventsEventA EventA)+-- <<EventA>>+--+-- We can also go from a 'MyEvents' value to an 'AllEvents' value:+--+-- >>> eventFromDyn (eventToDyn (MyEventsEventA EventA)) :: Maybe AllEvents+-- Just (AllEventsEventA EventA)+class EventSumType a where+  -- | Convert an event to a 'Dynamic' without the constructor tag+  eventToDyn :: a -> Dynamic++  -- | Go from a 'Dynamic' to an event with the constructor tag. Note, this+  -- function is @O(n)@ to the number of constructors.+  eventFromDyn :: Dynamic -> Maybe a++  default eventToDyn :: (Generic a, EventSumType' (Rep a)) => a -> Dynamic+  eventToDyn x = eventToDyn' (from x)++  default eventFromDyn :: (Generic a, EventSumType' (Rep a)) => Dynamic -> Maybe a+  eventFromDyn = fmap to . eventFromDyn'++-- Auxiliary type class for 'EventSumType' Generic fun+class EventSumType' f where+  eventToDyn' :: f p -> Dynamic+  eventFromDyn' :: Dynamic -> Maybe (f p)++-- M1 is the top-level metadata. We don't need the metadata so we just pass on+-- through.+instance (EventSumType' f) => EventSumType' (M1 i t f) where+  eventToDyn' (M1 x) = eventToDyn' x+  eventFromDyn' = fmap M1 . eventFromDyn'++-- The :+: operator is for when a type has multiple constructors. When+-- serializing, we just pass on through. When deserializing, we try the first+-- constructor, and if that fails then the second.+instance (EventSumType' f, EventSumType' g) => EventSumType' (f :+: g) where+  eventToDyn' (L1 x) = eventToDyn' x+  eventToDyn' (R1 x) = eventToDyn' x+  eventFromDyn' dyn = (L1 <$> eventFromDyn' dyn) <|> (R1 <$> eventFromDyn' dyn)++-- K1 R represents an actual constructor. This is where we do the actual+-- conversion to/from 'Dynamic'.+instance (Typeable c) => EventSumType' (K1 R c) where+  eventToDyn' (K1 x) = toDyn x+  eventFromDyn' dyn = K1 <$> fromDynamic dyn
+ src/Eventium/Store/Class.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Eventium.Store.Class+  ( -- * EventStore+    EventStoreReader (..),+    EventStoreWriter (..),+    VersionedEventStoreReader,+    GlobalEventStoreReader,+    VersionedEventStoreWriter,+    StreamEvent (..),+    VersionedStreamEvent,+    GlobalStreamEvent,+    ExpectedPosition (..),+    EventWriteError (..),+    runEventStoreReaderUsing,+    runEventStoreWriterUsing,+    module Eventium.Store.Queries,++    -- * Serialization+    serializedEventStoreReader,+    serializedVersionedEventStoreReader,+    serializedGlobalEventStoreReader,+    serializedEventStoreWriter,++    -- * Utility types+    EventVersion (..),+    SequenceNumber (..),++    -- * Utility functions+    transactionalExpectedWriteHelper,+  )+where++import Data.Aeson+import Data.Functor ((<&>))+import Data.Functor.Contravariant+import Data.Maybe (mapMaybe)+import Eventium.Serializer+import Eventium.Store.Queries+import Eventium.UUID+import Web.HttpApiData+import Web.PathPieces++-- | An 'EventStoreReader' is a function to query a stream from an event store.+-- It operates in some monad @m@ and returns events of type @event@ from a+-- stream at @key@ ordered by @position@.+newtype EventStoreReader key position m event = EventStoreReader {getEvents :: QueryRange key position -> m [event]}++instance (Functor m) => Functor (EventStoreReader key position m) where+  fmap f (EventStoreReader reader) = EventStoreReader $ fmap (fmap f) <$> reader++type VersionedEventStoreReader m event = EventStoreReader UUID EventVersion m (VersionedStreamEvent event)++type GlobalEventStoreReader m event = EventStoreReader () SequenceNumber m (GlobalStreamEvent event)++-- | An 'EventStoreWriter' is a function to write some events of type @event@+-- to an event store in some monad @m@.+newtype EventStoreWriter key position m event+  = EventStoreWriter {storeEvents :: key -> ExpectedPosition position -> [event] -> m (Either (EventWriteError position) EventVersion)}++instance Contravariant (EventStoreWriter key position m) where+  contramap f (EventStoreWriter writer) = EventStoreWriter $ \vers uuid -> writer vers uuid . fmap f++type VersionedEventStoreWriter = EventStoreWriter UUID EventVersion++-- | An event along with the @key@ for the event stream it is from and its+-- @position@ in that event stream.+data StreamEvent key position event+  = StreamEvent+  { streamEventKey :: !key,+    streamEventPosition :: !position,+    streamEventEvent :: !event+  }+  deriving (Show, Eq, Functor, Foldable, Traversable)++type VersionedStreamEvent event = StreamEvent UUID EventVersion event++type GlobalStreamEvent event = StreamEvent () SequenceNumber (VersionedStreamEvent event)++-- | ExpectedPosition is used to assert the event stream is at a certain+-- position. This is used when multiple writers are concurrently writing to the+-- event store. If the expected position is incorrect, then storing fails.+data ExpectedPosition position+  = -- | Used when the writer doesn't care what position the stream is at.+    AnyPosition+  | -- | The stream shouldn't exist yet.+    NoStream+  | -- | The stream should already exist.+    StreamExists+  | -- | Used to assert the stream is at a particular position.+    ExactPosition position+  deriving (Show, Eq)++newtype EventWriteError position+  = EventStreamNotAtExpectedVersion position+  deriving (Show, Eq)++-- | Helper to create 'storeEventsRaw' given a function to get the latest+-- stream version and a function to write to the event store. **NOTE**: This+-- only works if the monad @m@ is transactional.+transactionalExpectedWriteHelper ::+  (Monad m, Ord position, Num position) =>+  (key -> m position) ->+  (key -> [event] -> m EventVersion) ->+  key ->+  ExpectedPosition position ->+  [event] ->+  m (Either (EventWriteError position) EventVersion)+transactionalExpectedWriteHelper getLatestVersion' storeEvents' key expected =+  go expected getLatestVersion' storeEvents' key+  where+    go AnyPosition = transactionalExpectedWriteHelper' Nothing+    go NoStream = transactionalExpectedWriteHelper' (Just $ (==) (-1))+    go StreamExists = transactionalExpectedWriteHelper' (Just (> (-1)))+    go (ExactPosition pos) = transactionalExpectedWriteHelper' (Just $ (==) pos)++transactionalExpectedWriteHelper' ::+  (Monad m) =>+  Maybe (position -> Bool) ->+  (key -> m position) ->+  (key -> [event] -> m EventVersion) ->+  key ->+  [event] ->+  m (Either (EventWriteError position) EventVersion)+transactionalExpectedWriteHelper' Nothing _ storeEvents' uuid events =+  storeEvents' uuid events <&> Right+transactionalExpectedWriteHelper' (Just f) getLatestVersion' storeEvents' uuid events = do+  latestVersion <- getLatestVersion' uuid+  if f latestVersion+    then storeEvents' uuid events <&> Right+    else return $ Left $ EventStreamNotAtExpectedVersion latestVersion++-- | Changes the monad an 'EventStoreReader' runs in. This is useful to run+-- event stores in another 'Monad' while forgetting the original 'Monad'.+runEventStoreReaderUsing ::+  (Monad m, Monad mstore) =>+  (forall a. mstore a -> m a) ->+  EventStoreReader key position mstore event ->+  EventStoreReader key position m event+runEventStoreReaderUsing runStore (EventStoreReader f) = EventStoreReader (runStore . f)++-- | Analog of 'runEventStoreReaderUsing' for a 'EventStoreWriter'.+runEventStoreWriterUsing ::+  (Monad m, Monad mstore) =>+  (forall a. mstore a -> m a) ->+  EventStoreWriter key posirion mstore event ->+  EventStoreWriter key posirion m event+runEventStoreWriterUsing runStore (EventStoreWriter f) =+  EventStoreWriter $ \vers uuid events -> runStore $ f vers uuid events++-- | Wraps an 'EventStoreReader' and transparently serializes/deserializes+-- events for you. Note that in this implementation deserialization errors are+-- simply ignored (the event is not returned).+serializedEventStoreReader ::+  (Monad m) =>+  Serializer event serialized ->+  EventStoreReader key position m serialized ->+  EventStoreReader key position m event+serializedEventStoreReader Serializer {..} (EventStoreReader reader) =+  EventStoreReader $ fmap (mapMaybe deserialize) . reader++-- | Convenience wrapper around 'serializedEventStoreReader' for+-- 'VersionedEventStoreReader'.+serializedVersionedEventStoreReader ::+  (Monad m) =>+  Serializer event serialized ->+  VersionedEventStoreReader m serialized ->+  VersionedEventStoreReader m event+serializedVersionedEventStoreReader serializer = serializedEventStoreReader (traverseSerializer serializer)++-- | Convenience wrapper around 'serializedEventStoreReader' for+-- 'GlobalEventStoreReader'.+serializedGlobalEventStoreReader ::+  (Monad m) =>+  Serializer event serialized ->+  GlobalEventStoreReader m serialized ->+  GlobalEventStoreReader m event+serializedGlobalEventStoreReader serializer = serializedEventStoreReader (traverseSerializer (traverseSerializer serializer))++-- | Like 'serializedEventStoreReader' but for an 'EventStoreWriter'. Note that+-- 'EventStoreWriter' is an instance of 'Contravariant', so you can just use+-- @contramap serialize@ instead of this function.+serializedEventStoreWriter ::+  (Monad m) =>+  Serializer event serialized ->+  EventStoreWriter key position m serialized ->+  EventStoreWriter key position m event+serializedEventStoreWriter Serializer {..} = contramap serialize++-- | Event versions are a strictly increasing series of integers for each+-- projection. They allow us to order the events when they are replayed, and+-- they also help as a concurrency check in a multi-threaded environment so+-- services modifying the projection can be sure the projection didn't change+-- during their execution.+newtype EventVersion = EventVersion {unEventVersion :: Int}+  deriving (Show, Read, Ord, Eq, Enum, Num, FromJSON, ToJSON)++-- | The sequence number gives us a global ordering of events in a particular+-- event store. Using sequence numbers is not strictly necessary for an event+-- sourcing and CQRS system, but it makes it way easier to replay events+-- consistently without having to use distributed transactions in an event bus.+-- In SQL-based event stores, they are also very cheap to create.+newtype SequenceNumber = SequenceNumber {unSequenceNumber :: Int}+  deriving+    ( Show,+      Read,+      Ord,+      Eq,+      Enum,+      Num,+      FromJSON,+      ToJSON,+      PathPiece,+      ToHttpApiData,+      FromHttpApiData+    )
+ src/Eventium/Store/Queries.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeFamilies #-}++module Eventium.Store.Queries+  ( QueryRange (..),+    QueryStart (..),+    QueryLimit (..),+    allEvents,+    eventsUntil,+    eventsStartingAt,+    eventsStartingAtUntil,+    eventsStartingAtTakeLimit,+  )+where++-- | This type defines how to query an event stream. It defines the stream key+-- and the start/stop points for the query.+data QueryRange key position+  = QueryRange+  { queryRangeKey :: key,+    queryRangeStart :: QueryStart position,+    queryRangeLimit :: QueryLimit position+  }+  deriving (Show, Eq)++-- | This type defines where an event store query starts.+data QueryStart position+  = StartFromBeginning+  | StartQueryAt position+  deriving (Show, Eq, Functor)++-- | This type is used to limit the results of a query from an event store.+data QueryLimit position+  = NoQueryLimit+  | MaxNumberOfEvents Int+  | StopQueryAt position+  deriving (Show, Eq, Functor)++allEvents :: key -> QueryRange key position+allEvents key = QueryRange key StartFromBeginning NoQueryLimit++eventsUntil :: key -> position -> QueryRange key position+eventsUntil key end = QueryRange key StartFromBeginning (StopQueryAt end)++eventsStartingAt :: key -> position -> QueryRange key position+eventsStartingAt key start = QueryRange key (StartQueryAt start) NoQueryLimit++eventsStartingAtUntil :: key -> position -> position -> QueryRange key position+eventsStartingAtUntil key start end = QueryRange key (StartQueryAt start) (StopQueryAt end)++eventsStartingAtTakeLimit :: key -> position -> Int -> QueryRange key position+eventsStartingAtTakeLimit key start maxNum = QueryRange key (StartQueryAt start) (MaxNumberOfEvents maxNum)
+ src/Eventium/TH.hs view
@@ -0,0 +1,7 @@+module Eventium.TH+  ( module X,+  )+where++import Eventium.TH.Projection as X+import Eventium.TH.SumTypeSerializer as X
+ src/Eventium/TH/Projection.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Eventium.TH.Projection+  ( mkProjection,+  )+where++import Data.Char (toLower)+import Eventium.Projection+import Language.Haskell.TH+import SumTypesX.TH++-- | Creates a 'Projection' for a given type and a list of events. The user of+-- this function also needs to provide event handlers for each event. For+-- example:+--+-- @+--    data EventA = EventA+--    data EventB = EventB+--+--    data MyState = MyState Int+--+--    myStateDefault :: MyState+--    myStateDefault = MyState 0+--+--    mkProjection ''MyState 'myStateDefault [''EventA, ''EventB]+--+--    handleEventA :: MyState -> EventA -> MyState+--    handleEventA (MyState x) EventA = MyState (x + 1)+--+--    handleEventB :: MyState -> EventB -> MyState+--    handleEventB (MyState x) EventB = MyState (x - 1)+-- @+--+-- This will produce the following:+--+-- @+--    data MyStateEvent = MyStateEventA !EventA | MyStateEventB !EventB+--+--    handleMyStateEvent :: MyState -> MyStateEvent -> MyState+--    handleMyStateEvent state (MyStateEventA event) = handleEventA state event+--    handleMyStateEvent state (MyStateEventB event) = handleEventB state event+--+--    type MyStateProjection = Projection MyState MyStateEvent+--+--    myStateProjection :: MyStateProjection+--    myStateProjection = Projection myStateDefault handleMyStateEvent+-- @+mkProjection :: Name -> Name -> [Name] -> Q [Dec]+mkProjection stateName stateDefault events = do+  -- Make event sum type+  let eventTypeName = nameBase stateName ++ "Event"+  -- Make event sum type+  sumTypeDecls <- constructSumType eventTypeName defaultSumTypeOptions events++  -- Make function to handle events from sum type to handlers.+  let handleFuncName = mkName $ "handle" ++ eventTypeName+  handleFuncType <- [t|$(conT stateName) -> $(conT $ mkName eventTypeName) -> $(conT stateName)|]+  handleFuncBodies <- mapM (handleFuncBody stateName) events+  let handleTypeDecls =+        [ SigD handleFuncName handleFuncType,+          FunD handleFuncName handleFuncBodies+        ]++  -- Make the projection type+  projectionType <- [t|Projection $(conT stateName) $(conT $ mkName eventTypeName)|]+  let projectionTypeName = mkName $ nameBase stateName ++ "Projection"+      projectionTypeDecl = TySynD projectionTypeName [] projectionType++  -- Make the projection+  projectionFuncExpr <- [e|Projection $(varE stateDefault) $(varE handleFuncName)|]+  let projectionFuncName = mkName $ firstCharToLower (nameBase stateName) ++ "Projection"+      projectionFuncClause = Clause [] (NormalB projectionFuncExpr) []+      projectionDecls =+        [ SigD projectionFuncName (ConT projectionTypeName),+          FunD projectionFuncName [projectionFuncClause]+        ]++  return $ sumTypeDecls ++ handleTypeDecls ++ [projectionTypeDecl] ++ projectionDecls++handleFuncBody :: Name -> Name -> Q Clause+handleFuncBody stateName event = do+  let statePattern = VarP (mkName "state")+      eventPattern = ConP (mkName $ nameBase stateName ++ nameBase event) [] [VarP (mkName "event")]+      handleFuncName = mkName $ "handle" ++ nameBase event+  constructor <- [e|$(varE handleFuncName) $(varE $ mkName "state") $(varE $ mkName "event")|]+  return $ Clause [statePattern, eventPattern] (NormalB constructor) []++firstCharToLower :: String -> String+firstCharToLower [] = []+firstCharToLower (x : xs) = toLower x : xs
+ src/Eventium/TH/SumTypeSerializer.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Eventium.TH.SumTypeSerializer+  ( mkSumTypeSerializer,+  )+where++import Data.Char (toLower)+import Language.Haskell.TH+import SumTypesX.TH++-- | This is a template haskell function that creates a 'Serializer' between+-- two sum types. The first sum type must be a subset of the second sum type.+-- This is useful in situations where you define all the events in your system+-- in one type, and you want to create sum types that are subsets for each+-- 'Projection'.+--+-- For example, assume we have the following three event types and two sum+-- types holding these events:+--+-- @+--    data EventA = EventA+--    data EventB = EventB+--    data EventC = EventC+--+--    data AllEvents+--      = AllEventsEventA EventA+--      | AllEventsEventB EventB+--      | AllEventsEventC EventC+--+--    data MyEvents+--      = MyEventsEventA EventA+--      | MyEventsEventB EventB+-- @+--+-- In this case, @AllEvents@ holds all the events in our system, and @MyEvents@+-- holds some subset of @AllEvents@. If we run+--+-- @+--    mkSumTypeSerializer "myEventsSerializer" ''MyEvents ''AllEvents+-- @+--+-- we will produce the following code:+--+-- @+--    -- Serialization function+--    myEventsToAllEvents :: MyEvents -> AllEvents+--    myEventsToAllEvents (MyEventsEventA e) = AllEventsEventA e+--    myEventsToAllEvents (MyEventsEventB e) = AllEventsEventB e+--+--    -- Deserialization function+--    allEventsToMyEvents :: AllEvents -> Maybe MyEvents+--    allEventsToMyEvents (AllEventsEventA e) = Just (MyEventsEventA e)+--    allEventsToMyEvents (AllEventsEventB e) = Just (MyEventsEventB e)+--    allEventsToMyEvents _ = Nothing+--+--    -- Serializer+--    myEventsSerializer :: Serializer MyEvents AllEvents+--    myEventsSerializer = simpleSerializer myEventsToAllEvents allEventsToMyEvents+-- @+mkSumTypeSerializer :: String -> Name -> Name -> Q [Dec]+mkSumTypeSerializer serializerName sourceType targetType = do+  -- Construct the serialization function+  let serializeFuncName = firstCharToLower (nameBase sourceType) ++ "To" ++ nameBase targetType+      deserializeFuncName = firstCharToLower (nameBase targetType) ++ "To" ++ nameBase sourceType+  -- Generate the sum type converter functions+  serializeDecls <- sumTypeConverter serializeFuncName sourceType targetType+  deserializeDecls <- partialSumTypeConverter deserializeFuncName targetType sourceType++  -- Construct the serializer+  serializerTypeDecl <- [t|$(conT $ mkName "Serializer") $(conT sourceType) $(conT targetType)|]+  serializerExp <- [e|$(varE $ mkName "simpleSerializer") $(varE $ mkName serializeFuncName) $(varE $ mkName deserializeFuncName)|]+  let serializerClause = Clause [] (NormalB serializerExp) []++  return $+    [ SigD (mkName serializerName) serializerTypeDecl,+      FunD (mkName serializerName) [serializerClause]+    ]+      ++ serializeDecls+      ++ deserializeDecls++firstCharToLower :: String -> String+firstCharToLower [] = []+firstCharToLower (x : xs) = toLower x : xs
+ src/Eventium/UUID.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This module contains orphan 'UUID' instances and a few convenience+-- functions around UUIDs. It would be great if this were its own entirely+-- separate package.+module Eventium.UUID+  ( UUID,+    uuidFromText,+    uuidToText,+    nil,+    uuidNextRandom,+    uuidFromInteger,+  )+where++import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import Data.UUID+import qualified Data.UUID.V4 as UUID4+import Text.Printf (printf)+import Web.PathPieces++#if MIN_VERSION_aeson(1,1,0)++#else+import Data.Aeson (ToJSON (..), FromJSON (..))++instance ToJSON UUID where+  toJSON uuid = toJSON (toText uuid)++instance FromJSON UUID where+  parseJSON text = do+    uuid <- parseJSON text+    maybe (fail $ "Error parsing UUID " ++ show uuid) pure (fromText uuid)+#endif++uuidFromText :: Text -> Maybe UUID+uuidFromText = fromText++uuidToText :: UUID -> Text+uuidToText = toText++uuidNextRandom :: IO UUID+uuidNextRandom = UUID4.nextRandom++instance PathPiece UUID where+  fromPathPiece = uuidFromText+  toPathPiece = uuidToText++-- | Constructs a valid 'UUID' from an 'Integer' by padding with zeros. Useful+-- for testing.+--+-- >>> uuidFromInteger 1+-- 00000000-0000-0000-0000-000000000001+uuidFromInteger :: Integer -> UUID+uuidFromInteger i =+  let rawString = take 32 $ printf "%032x" i+      (p1, rest1) = splitAt 8 rawString+      (p2, rest2) = splitAt 4 rest1+      (p3, rest3) = splitAt 4 rest2+      (p4, p5) = splitAt 4 rest3+      withHyphens = intercalate "-" [p1, p2, p3, p4, p5]+      mUuid = uuidFromText . pack $ withHyphens+   in fromMaybe (error $ "Failure in uuidFrominteger for: " ++ show i) mUuid
+ tests/Eventium/SerializerSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module Eventium.SerializerSpec (spec) where++import Data.Dynamic+import Data.Typeable (typeOf)+import Eventium.Serializer+import Eventium.TH.SumTypeSerializer+import GHC.Generics+import Test.Hspec++data EventA = EventA deriving (Show, Eq)++data EventB = EventB deriving (Show, Eq)++data EventC = EventC deriving (Show, Eq)++data AllEvents+  = AllEventsEventA EventA+  | AllEventsEventB EventB+  | AllEventsEventC EventC+  deriving (Show, Eq, Generic)++instance EventSumType AllEvents++data MyEvents+  = MyEventsEventA EventA+  | MyEventsEventB EventB+  deriving (Show, Eq, Generic)++instance EventSumType MyEvents++mkSumTypeSerializer "myEventsSerializer" ''MyEvents ''AllEvents++spec :: Spec+spec = do+  describe "EventSumType" $ do+    it "can serialize events without the constructor" $ do+      dynTypeRep (eventToDyn $ MyEventsEventA EventA) `shouldBe` typeOf EventA+      dynTypeRep (eventToDyn $ MyEventsEventA EventA) `shouldBe` dynTypeRep (eventToDyn $ AllEventsEventA EventA)++    it "can deserialize events with the constructor" $ do+      eventFromDyn (toDyn EventA) `shouldBe` Just (MyEventsEventA EventA)+      eventFromDyn (toDyn EventB) `shouldBe` Just (AllEventsEventB EventB)++      eventFromDyn (eventToDyn $ MyEventsEventA EventA) `shouldBe` Just (AllEventsEventA EventA)+      eventFromDyn (eventToDyn $ AllEventsEventB EventB) `shouldBe` Just (MyEventsEventB EventB)++  describe "mkSumTypeSerializer" $ do+    it "can serialize events" $ do+      serialize myEventsSerializer (MyEventsEventA EventA) `shouldBe` AllEventsEventA EventA+      serialize myEventsSerializer (MyEventsEventB EventB) `shouldBe` AllEventsEventB EventB++    it "can deserialize events" $ do+      deserialize myEventsSerializer (AllEventsEventA EventA) `shouldBe` Just (MyEventsEventA EventA)+      deserialize myEventsSerializer (AllEventsEventB EventB) `shouldBe` Just (MyEventsEventB EventB)+      deserialize myEventsSerializer (AllEventsEventC EventC) `shouldBe` Nothing
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}