diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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) diff --git a/eventium-core.cabal b/eventium-core.cabal new file mode 100644 --- /dev/null +++ b/eventium-core.cabal @@ -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 diff --git a/src/Eventium.hs b/src/Eventium.hs new file mode 100644 --- /dev/null +++ b/src/Eventium.hs @@ -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 diff --git a/src/Eventium/CommandHandler.hs b/src/Eventium/CommandHandler.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/CommandHandler.hs @@ -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 diff --git a/src/Eventium/EventBus.hs b/src/Eventium/EventBus.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/EventBus.hs @@ -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 diff --git a/src/Eventium/ProcessManager.hs b/src/Eventium/ProcessManager.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/ProcessManager.hs @@ -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] diff --git a/src/Eventium/Projection.hs b/src/Eventium/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/Projection.hs @@ -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 diff --git a/src/Eventium/ProjectionCache/Types.hs b/src/Eventium/ProjectionCache/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/ProjectionCache/Types.hs @@ -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 diff --git a/src/Eventium/ReadModel/Class.hs b/src/Eventium/ReadModel/Class.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/ReadModel/Class.hs @@ -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) diff --git a/src/Eventium/Serializer.hs b/src/Eventium/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/Serializer.hs @@ -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) +-- <> +-- +-- 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 diff --git a/src/Eventium/Store/Class.hs b/src/Eventium/Store/Class.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/Store/Class.hs @@ -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 + ) diff --git a/src/Eventium/Store/Queries.hs b/src/Eventium/Store/Queries.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/Store/Queries.hs @@ -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) diff --git a/src/Eventium/TH.hs b/src/Eventium/TH.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/TH.hs @@ -0,0 +1,7 @@ +module Eventium.TH + ( module X, + ) +where + +import Eventium.TH.Projection as X +import Eventium.TH.SumTypeSerializer as X diff --git a/src/Eventium/TH/Projection.hs b/src/Eventium/TH/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/TH/Projection.hs @@ -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 diff --git a/src/Eventium/TH/SumTypeSerializer.hs b/src/Eventium/TH/SumTypeSerializer.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/TH/SumTypeSerializer.hs @@ -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 diff --git a/src/Eventium/UUID.hs b/src/Eventium/UUID.hs new file mode 100644 --- /dev/null +++ b/src/Eventium/UUID.hs @@ -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 diff --git a/tests/Eventium/SerializerSpec.hs b/tests/Eventium/SerializerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Eventium/SerializerSpec.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}