packages feed

eventful-core (empty) → 0.1.0

raw patch · 21 files changed

+1259/−0 lines, 21 filesdep +HUnitdep +aesondep +base

Dependencies added: HUnit, aeson, base, containers, hlint, hspec, http-api-data, path-pieces, template-haskell, text, transformers, uuid

Files

+ CHANGELOG.md view
+ LICENSE.md view
@@ -0,0 +1,19 @@+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,1 @@+# Eventful core
+ eventful-core.cabal view
@@ -0,0 +1,113 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name:           eventful-core+version:        0.1.0+synopsis:       Core module for eventful+description:    Core module for eventful+category:       Database,Eventsourcing+stability:      experimental+maintainer:     David Reaver+license:        MIT+license-file:   LICENSE.md+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    CHANGELOG.md+    README.md++library+  hs-source-dirs:+      src+  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , aeson+    , containers+    , http-api-data+    , path-pieces+    , template-haskell+    , text+    , transformers+    , uuid+  exposed-modules:+      Eventful+      Eventful.Aggregate+      Eventful.EventBus+      Eventful.ProcessManager+      Eventful.Projection+      Eventful.ReadModel.Class+      Eventful.Serializer+      Eventful.Store.Class+      Eventful.TH+      Eventful.TH.Projection+      Eventful.TH.SumType+      Eventful.TH.SumTypeSerializer+      Eventful.UUID+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      tests+      src+  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , aeson+    , containers+    , http-api-data+    , path-pieces+    , template-haskell+    , text+    , transformers+    , uuid+    , hspec+    , HUnit+  other-modules:+      Eventful.SerializerSpec+      Eventful.TH.SumTypeSpec+      HLint+      Eventful+      Eventful.Aggregate+      Eventful.EventBus+      Eventful.ProcessManager+      Eventful.Projection+      Eventful.ReadModel.Class+      Eventful.Serializer+      Eventful.Store.Class+      Eventful.TH+      Eventful.TH.Projection+      Eventful.TH.SumType+      Eventful.TH.SumTypeSerializer+      Eventful.UUID+  default-language: Haskell2010++test-suite style+  type: exitcode-stdio-1.0+  main-is: HLint.hs+  hs-source-dirs:+      tests+  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , aeson+    , containers+    , http-api-data+    , path-pieces+    , template-haskell+    , text+    , transformers+    , uuid+    , hlint+  other-modules:+      Eventful.SerializerSpec+      Eventful.TH.SumTypeSpec+      Spec+  default-language: Haskell2010
+ src/Eventful.hs view
@@ -0,0 +1,12 @@+module Eventful+  ( module X+  ) where++import Eventful.Aggregate as X+import Eventful.EventBus as X+import Eventful.Projection as X+import Eventful.ProcessManager as X+import Eventful.ReadModel.Class as X+import Eventful.Serializer as X+import Eventful.Store.Class as X+import Eventful.UUID as X
+ src/Eventful/Aggregate.hs view
@@ -0,0 +1,54 @@+-- | Defines an Aggregate type-class from DDD parlance.++module Eventful.Aggregate+  ( Aggregate (..)+  , allAggregateStates+  , commandStoredAggregate+  ) where++import Data.Foldable (foldl')+import Data.List (scanl')++import Eventful.Projection+import Eventful.Store.Class+import Eventful.UUID++-- | An 'Aggregate' is a combination of a 'Projection' and a function to+-- validate commands against that 'Projection'. When using an aggregate 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 Aggregate state event cmd =+  Aggregate+  { aggregateCommandHandler :: state -> cmd -> [event]+  , aggregateProjection :: Projection state event+  }++-- | Given a list commands, produce all of the states the aggregate's+-- projection sees. This is useful for unit testing aggregates.+allAggregateStates+  :: Aggregate state event cmd+  -> [cmd]+  -> [state]+allAggregateStates (Aggregate commandHandler (Projection seed eventHandler)) events =+  scanl' go seed events+  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 'Aggregate' command to it. If the command succeeds, then this+-- saves the events back to the store as well.+commandStoredAggregate+  :: (Monad m)+  => EventStore serialized m+  -> Aggregate state serialized cmd+  -> UUID+  -> cmd+  -> m [serialized]+commandStoredAggregate store (Aggregate handler proj) uuid command = do+  (latest, vers) <- getLatestProjection store proj uuid+  let events = handler latest command+  mError <- storeEvents store (ExactVersion vers) uuid events+  case mError of+    (Just err) -> error $ "TODO: Create aggregate restart logic. " ++ show err+    Nothing -> return events
+ src/Eventful/EventBus.hs view
@@ -0,0 +1,50 @@+module Eventful.EventBus+  ( synchronousEventBusWrapper+  , storeAndPublishEvents+  ) where++import Eventful.Store.Class+import Eventful.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)+  => EventStore serialized m+  -> [EventStore serialized m -> UUID -> serialized -> m ()]+  -> EventStore serialized m+synchronousEventBusWrapper store handlers =+  let+    -- NB: We need to use recursive let bindings so we can put wrappedStore+    -- inside the event handlers+    handlers' = map ($ wrappedStore) handlers+    wrappedStore =+      EventStore+      { getLatestVersion = getLatestVersion store+      , getEvents = getEvents store+      , storeEvents = storeAndPublishEvents store handlers'+      }+  in wrappedStore++-- | Stores events in the store and them publishes them to the event handlers.+-- This is used in the 'synchronousEventBusWrapper'.+storeAndPublishEvents+  :: (Monad m)+  => EventStore serialized m+  -> [UUID -> serialized -> m ()]+  -> ExpectedVersion+  -> UUID+  -> [serialized]+  -> m (Maybe EventWriteError)+storeAndPublishEvents store handlers expectedVersion uuid events = do+  result <- storeEvents store expectedVersion uuid events+  case result of+    Just err -> return $ Just err+    Nothing -> 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 Nothing
+ src/Eventful/ProcessManager.hs view
@@ -0,0 +1,92 @@+module Eventful.ProcessManager+  ( ProcessManager (..)+  , ProcessManagerCommand (..)+  , ProcessManagerEvent (..)+  , ProcessManagerRouter (..)+  , processManagerHandler+  ) where++import Control.Monad (forM_, void)++import Eventful.Aggregate+import Eventful.Projection+import Eventful.Store.Class+import Eventful.UUID++-- | A 'ProcessManager' manages interaction between aggregates. It works by+-- listening to events on an event bus (see 'processManagerHandler') and+-- applying events to its internal 'Projection'. Then, pending commands and+-- events are plucked off of that Projection and applied to the appropriate+-- Aggregates or Projections in other streams.+data ProcessManager state event command+  = ProcessManager+  { processManagerProjection :: Projection state event+  , processManagerPendingCommands :: state -> [ProcessManagerCommand event command]+  , processManagerPendingEvents :: state -> [ProcessManagerEvent event]+  }++-- | This is a @command@ along with the UUID of the target 'Aggregate', and+-- well as the 'Aggregate' instance. Note that this uses an existential type to+-- hide the @state@ type parameter on the Aggregate.+data ProcessManagerCommand event command+  = forall state. ProcessManagerCommand+  { processManagerCommandAggregateId :: UUID+  , processManagerCommandAggregate :: Aggregate state event command+  , processManagerCommandCommand :: command+  }++instance (Show command, Show event) => Show (ProcessManagerCommand event command) where+  show (ProcessManagerCommand uuid _ command) =+    "ProcessManagerCommand{ processManagerCommandAggregateId = " ++ show uuid +++    ", processManagerCommandCommand = " ++ show command++-- | This is an @event@ paired with the UUID of the stream to which the event+-- will be applied.+data ProcessManagerEvent event+  = ProcessManagerEvent+  { processManagerEventProjectionId :: UUID+  , processManagerEventEvent :: event+  } deriving (Show, Eq)++-- | A 'ProcessManagerRouter' decides which process manager projection ID to+-- use for a given event.+data ProcessManagerRouter state event command+  = ProcessManagerRouter+  { processManagerRouterGetManagerId :: UUID -> event -> Maybe UUID+    -- TODO: Should this really be just "Maybe UUID"? We should consider+    -- allowing UUID creation as well when the first event for a process comes+    -- in so we know every process manager has a unique UUID. We could make an+    -- ADT for ProcessManagerRouteResult that returns either the UUID, a value+    -- saying we need to make a UUID, or a value saying the manager ignores+    -- that event.+  , processManagerRouterManager :: ProcessManager state event command+  }++-- | This is an event handler for a 'ProcessManager' that applies all events to+-- the 'ProcessManagerRouter', and then applied any pending commands or events+-- to the appropriate places.+processManagerHandler+  :: (Monad m)+  => ProcessManagerRouter state event command+  -> EventStore event m+  -> UUID+  -> event+  -> m ()+processManagerHandler (ProcessManagerRouter getManagerId manager) store eventAggregateId event =+  maybe (return ()) (processManagerHandler' manager store event) (getManagerId eventAggregateId event)++processManagerHandler'+  :: (Monad m)+  => ProcessManager state event command+  -> EventStore event m+  -> event+  -> UUID+  -> m ()+processManagerHandler' ProcessManager{..} store startEvent managerId = do+  -- TODO: Don't ignore storage errors+  _ <- storeEvents store AnyVersion managerId [startEvent]+  (managerState, _) <- getLatestProjection store processManagerProjection managerId+  forM_ (processManagerPendingCommands managerState) $ \(ProcessManagerCommand aggregateId aggregate command) ->+    void $ commandStoredAggregate store aggregate aggregateId command+  forM_ (processManagerPendingEvents managerState) $ \(ProcessManagerEvent projectionId event) ->+    storeEvents store AnyVersion projectionId [event]
+ src/Eventful/Projection.hs view
@@ -0,0 +1,57 @@+module Eventful.Projection+  ( Projection (..)+  , latestProjection+  , allProjections+  , getLatestProjection+  )+  where++import Data.Foldable (foldl')+import Data.List (scanl')++import Eventful.Store.Class+import Eventful.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+  { projectionSeed :: state+    -- ^ Initial state of a projection+  , projectionEventHandler :: state -> event -> state+    -- ^ The function that applies and event to the current state, producing a+    -- new state.+  }++-- | 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++-- | Gets the latest projection from a store by using 'getEvents' and then+-- applying the events using the Projection's event handler.+getLatestProjection+  :: (Monad m)+  => EventStore serialized m+  -> Projection proj serialized+  -> UUID+  -> m (proj, EventVersion)+getLatestProjection store proj uuid = do+  events <- getEvents store uuid Nothing+  let+    latestVersion = maxEventVersion events+    latestProj = latestProjection proj $ storedEventEvent <$> events+  return (latestProj, latestVersion)+  where+    maxEventVersion [] = -1+    maxEventVersion es = maximum $ storedEventVersion <$> es
+ src/Eventful/ReadModel/Class.hs view
@@ -0,0 +1,45 @@+module Eventful.ReadModel.Class+  ( ReadModel (..)+  , runPollingReadModel+  ) where++import Control.Concurrent (threadDelay)+import Control.Monad (forever)+import Control.Monad.IO.Class (liftIO, MonadIO)++import Eventful.Store.Class++data ReadModel model serialized m =+  ReadModel+  { readModelModel :: model+  , readModelLatestAppliedSequence :: model -> m SequenceNumber+  , readModelHandleEvents :: model -> [GloballyOrderedEvent (StoredEvent serialized)] -> m ()+  }++type PollingPeriodSeconds = Double++runPollingReadModel+  :: (MonadIO m, Monad mstore)+  => ReadModel model serialized m+  -> GloballyOrderedEventStore serialized mstore+  -> (forall a. mstore a -> m a)+  -> PollingPeriodSeconds+  -> m ()+runPollingReadModel ReadModel{..} getGloballyOrderedEvents runStore waitSeconds = forever $ do+  -- Get new events starting from latest applied sequence number+  latestSeq <- readModelLatestAppliedSequence readModelModel+  newEvents <- runStore $ getSequencedEvents getGloballyOrderedEvents (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/Eventful/Serializer.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}++module Eventful.Serializer+  ( -- * Class+    Serializer (..)+  , simpleSerializer+  , composeSerializers+    -- * Common serializers+  , idSerializer+  , jsonSerializer+  , jsonTextSerializer+  , dynamicSerializer+    -- * Serialized event store+  , serializedEventStore+  , serializedGloballyOrderedEventStore+    -- * Sum types+  , EventSumType (..)+  , eventSumTypeSerializer+  ) where++import Control.Applicative ((<|>))+import Data.Aeson+import Data.Dynamic+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import GHC.Generics++import Eventful.Store.Class++-- | 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+  , deserializeEither :: b -> Either String a+    -- ^ Deserialize with additional information on failure+  }++-- | 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++-- | 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++-- | Wraps an 'EventStore' 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).+serializedEventStore+  :: (Monad m)+  => Serializer event serialized+  -> EventStore serialized m+  -> EventStore event m+serializedEventStore Serializer{..} store =+  EventStore+  (getLatestVersion store)+  getEvents'+  storeEvents'+  where+    getEvents' uuid mVersion = mapMaybe (traverse deserialize) <$> getEvents store uuid mVersion+    storeEvents' expectedVersion uuid events = storeEvents store expectedVersion uuid (serialize <$> events)++-- | Like 'serializedEventStore' except for 'GloballyOrderedEventStore'.+serializedGloballyOrderedEventStore+  :: (Monad m)+  => Serializer event serialized+  -> GloballyOrderedEventStore serialized m+  -> GloballyOrderedEventStore event m+serializedGloballyOrderedEventStore Serializer{..} store =+  GloballyOrderedEventStore getSequencedEvents'+  where+    getSequencedEvents' sequenceNumber =+      mapMaybe (traverse (traverse deserialize)) <$> getSequencedEvents store sequenceNumber++-- | 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/Eventful/Store/Class.hs view
@@ -0,0 +1,130 @@+module Eventful.Store.Class+  ( -- * EventStore+    EventStore (..)+  , GloballyOrderedEventStore (..)+  , ExpectedVersion (..)+  , EventWriteError (..)+    -- * Utility types+  , StoredEvent (..)+  , GloballyOrderedEvent (..)+  , EventVersion (..)+  , SequenceNumber (..)+    -- * Utility functions+  , transactionalExpectedWriteHelper+  ) where++import Data.Aeson+import Web.HttpApiData+import Web.PathPieces++import Eventful.UUID++-- | The 'EventStore' is the core type of eventful. A store operates in some+-- monad @m@ and stores events by serializing them to the type @serialized@.+data EventStore serialized m+  = EventStore+  { getLatestVersion :: UUID -> m EventVersion+    -- ^ Gets the latest 'EventVersion' for a given 'Projection'.+  , getEvents :: UUID -> Maybe EventVersion -> m [StoredEvent serialized]+    -- ^ Retrieves all the events for a given 'Projection' using that+    -- projection's UUID. If an event version is provided then all events with+    -- a version greater than or equal to that version are returned.+  , storeEvents :: ExpectedVersion -> UUID -> [serialized] -> m (Maybe EventWriteError)+    -- ^ Stores the events for a given 'Projection' using that projection's+    -- UUID.+  }++-- | Gets all the events ordered starting with a given 'SequenceNumber', and+-- ordered by 'SequenceNumber'. This is used when replaying all the events in a+-- store.+newtype GloballyOrderedEventStore serialized m =+  GloballyOrderedEventStore+  { getSequencedEvents :: SequenceNumber -> m [GloballyOrderedEvent (StoredEvent serialized)]+  }++-- | ExpectedVersion is used to assert the event stream is at a certain version+-- number. This is used when multiple writers are concurrently writing to the+-- event store. If the expected version is incorrect, then storing fails.+data ExpectedVersion+  = AnyVersion+    -- ^ Used when the writer doesn't care what version the stream is at.+  | NoStream+    -- ^ The stream shouldn't exist yet.+  | StreamExists+    -- ^ The stream should already exist.+  | ExactVersion EventVersion+    -- ^ Used to assert the stream is at a particular version.+  deriving (Show, Eq)++data EventWriteError+  = EventStreamNotAtExpectedVersion EventVersion+  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)+  => (UUID -> m EventVersion)+  -> (UUID -> [serialized] -> m ())+  -> ExpectedVersion -> UUID -> [serialized] -> m (Maybe EventWriteError)+transactionalExpectedWriteHelper getLatestVersion' storeEvents' expected =+  go expected getLatestVersion' storeEvents'+  where+    go AnyVersion = transactionalExpectedWriteHelper' Nothing+    go NoStream = transactionalExpectedWriteHelper' (Just $ (==) (-1))+    go StreamExists = transactionalExpectedWriteHelper' (Just (> (-1)))+    go (ExactVersion vers) = transactionalExpectedWriteHelper' (Just $ (==) vers)++transactionalExpectedWriteHelper'+  :: (Monad m)+  => Maybe (EventVersion -> Bool)+  -> (UUID -> m EventVersion)+  -> (UUID -> [serialized] -> m ())+  -> UUID -> [serialized] -> m (Maybe EventWriteError)+transactionalExpectedWriteHelper' Nothing _ storeEvents' uuid events =+  storeEvents' uuid events >> return Nothing+transactionalExpectedWriteHelper' (Just f) getLatestVersion' storeEvents' uuid events = do+  latestVersion <- getLatestVersion' uuid+  if f latestVersion+  then storeEvents' uuid events >> return Nothing+  else return $ Just $ EventStreamNotAtExpectedVersion latestVersion++-- | A 'StoredEvent' is an event with associated storage metadata.+data StoredEvent event+  = StoredEvent+  { storedEventProjectionId :: UUID+    -- ^ The UUID of the 'Projection' that the event belongs to.+  , storedEventVersion :: EventVersion+    -- ^ The version of the Projection corresponding to this event.+  , storedEventEvent :: event+    -- ^ The actual event type. Note that this can be a serialized event or the+    -- actual Haskell event type.+  } deriving (Show, Eq, Functor, Foldable, Traversable)++-- | A 'GloballyOrderedEvent' is an event that has a global 'SequenceNumber'.+data GloballyOrderedEvent event+  = GloballyOrderedEvent+  { globallyOrderedEventSequenceNumber :: SequenceNumber+    -- ^ The global sequence number of this event.+  , globallyOrderedEventEvent :: event+    -- ^ The actual event type. Note that this can be a serialized event or the+    -- actual Haskell event type.+  } deriving (Show, Eq, Functor, Foldable, Traversable)++-- | 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/Eventful/TH.hs view
@@ -0,0 +1,7 @@+module Eventful.TH+  ( module X+  ) where++import Eventful.TH.Projection as X+import Eventful.TH.SumType as X+import Eventful.TH.SumTypeSerializer as X
+ src/Eventful/TH/Projection.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE QuasiQuotes #-}++module Eventful.TH.Projection+  ( mkProjection+  ) where++import Data.Char (toLower)+import Language.Haskell.TH++import Eventful.Projection+import Eventful.TH.SumType++-- | 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"+  sumTypeDecls <- mkSumType eventTypeName (nameBase stateName ++) 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/Eventful/TH/SumType.hs view
@@ -0,0 +1,51 @@+module Eventful.TH.SumType+  ( mkSumType+  , mkSumType'+  ) where++import Language.Haskell.TH++-- | This is a template haskell function that creates a sum type from a list of+-- types. This is very useful when creating an event type for a 'Projection'+-- from a list of events in your system. Here is an example:+--+-- @+--    data EventA = EventA+--    data EventB = EventB+--    data EventC = EventC+--+--    mkSumType "MyEvent" ("MyEvent" ++) [''EventA, ''EventB, ''EventC]+-- @+--+-- This will produce the following sum type:+--+-- @+--    data MyEvent+--      = MyEventEventA EventA+--      | MyEventEventB EventB+--      | MyEventEventC EventC+-- @+--+-- Note that you can use standalone deriving to derive any instances you want:+--+-- @+--    deriving instance Show MyEvent+--    deriving instance Eq MyEvent+-- @+mkSumType :: String -> (String -> String) -> [Name] -> Q [Dec]+mkSumType typeName mkConstructorName eventTypes = do+  let+    mkConstructor eventName =+      NormalC+      (mkName . mkConstructorName . nameBase $ eventName)+      [(Bang NoSourceUnpackedness SourceStrict, ConT eventName)]+    constructors = map mkConstructor eventTypes+  return [DataD [] (mkName typeName) [] Nothing constructors []]++-- | Variant of mkSumType that just appends a @'@ to each constructor.+--+-- @+--    mkSumType' name events = mkSumType name (++ "'") events+-- @+mkSumType' :: String -> [Name] -> Q [Dec]+mkSumType' name = mkSumType name (++ "'")
+ src/Eventful/TH/SumTypeSerializer.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE QuasiQuotes #-}++module Eventful.TH.SumTypeSerializer+  ( mkSumTypeSerializer+  ) where++import Data.Char (toLower)+import Data.List (lookup)+import Language.Haskell.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+  -- Get the constructors for both types and match them up based on event type.+  sourceConstructors <- typeConstructors sourceType+  targetConstructors <- typeConstructors targetType+  bothConstructors <- mapM (matchConstructor targetConstructors) sourceConstructors++  -- Construct the serialization function+  let+    serializeFuncName = mkName $ firstCharToLower (nameBase sourceType) ++ "To" ++ nameBase targetType+    serializeFuncClauses = map mkSerializeFunc bothConstructors+  serializeTypeDecl <- [t| $(conT sourceType) -> $(conT targetType) |]++  -- Construct the deserialization function+  let+    deserializeFuncName = mkName $ firstCharToLower (nameBase targetType) ++ "To" ++ nameBase sourceType+    wildcardDeserializeClause = Clause [WildP] (NormalB (ConE 'Nothing)) []+    deserializeFuncClauses = map mkDeserializeFunc bothConstructors ++ [wildcardDeserializeClause]+  deserializeTypeDecl <- [t| $(conT targetType) -> Maybe $(conT sourceType) |]++  -- Construct the serializer+  serializerTypeDecl <- [t| $(conT $ mkName "Serializer") $(conT sourceType) $(conT targetType) |]+  serializerExp <- [e| $(varE $ mkName "simpleSerializer") $(varE serializeFuncName) $(varE deserializeFuncName) |]+  let+    serializerClause = Clause [] (NormalB serializerExp) []++  return+    [ -- Serialization+      SigD serializeFuncName serializeTypeDecl+    , FunD serializeFuncName serializeFuncClauses++      -- Deserialization+    , SigD deserializeFuncName deserializeTypeDecl+    , FunD deserializeFuncName deserializeFuncClauses++      -- Serializer+    , SigD (mkName serializerName) serializerTypeDecl+    , FunD (mkName serializerName) [serializerClause]+    ]++-- | Extract the constructors and event types for the given type.+typeConstructors :: Name -> Q [(Type, Name)]+typeConstructors typeName = do+  info <- reify typeName+  case info of+    (TyConI (DataD _ _ _ _ constructors _)) -> mapM go constructors+      where+        go (NormalC name []) = fail $ "Constructor " ++ nameBase name ++ " doesn't have any arguments"+        go (NormalC name [(_, type')]) = return (type', name)+        go (NormalC name _) = fail $ "Constructor " ++ nameBase name ++ " has more than one argument"+        go _ = fail $ "Invalid constructor in " ++ nameBase typeName+    _ -> fail $ nameBase typeName ++ " must be a sum type"++-- | Find the corresponding target constructor for a given source constructor.+matchConstructor :: [(Type, Name)] -> (Type, Name) -> Q BothConstructors+matchConstructor targetConstructors (type', sourceConstructor) = do+  targetConstructor <-+    maybe+    (fail $ "Can't find constructor in target type corresponding to " ++ nameBase sourceConstructor)+    return+    (lookup type' targetConstructors)+  return $ BothConstructors type' sourceConstructor targetConstructor++-- | Utility type to hold the source and target constructors for a given event+-- type.+data BothConstructors =+  BothConstructors+  { eventType :: Type+  , sourceConstructor :: Name+  , targetConstructor :: Name+  }++-- | Construct the TH function 'Clause' for the serialization function for a+-- given type.+mkSerializeFunc :: BothConstructors -> Clause+mkSerializeFunc BothConstructors{..} =+  let+    patternMatch = ConP sourceConstructor [VarP (mkName "e")]+    constructor = AppE (ConE targetConstructor) (VarE (mkName "e"))+  in Clause [patternMatch] (NormalB constructor) []++-- | Construct the TH function 'Clause' for the deserialization function for a+-- given type.+mkDeserializeFunc :: BothConstructors -> Clause+mkDeserializeFunc BothConstructors{..} =+  let+    patternMatch = ConP targetConstructor [VarP (mkName "e")]+    constructor = AppE (ConE 'Just) (AppE (ConE sourceConstructor) (VarE (mkName "e")))+  in Clause [patternMatch] (NormalB constructor) []++firstCharToLower :: String -> String+firstCharToLower [] = []+firstCharToLower (x:xs) = toLower x : xs
+ src/Eventful/UUID.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}++-- | 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 Eventful.UUID+  ( UUID+  , uuidFromText+  , uuidToText+  , nil+  , uuidNextRandom+  , uuidFromInteger+  ) where++import Data.UUID+import qualified Data.UUID.V4 as UUID4++import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+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/Eventful/SerializerSpec.hs view
@@ -0,0 +1,53 @@+module Eventful.SerializerSpec (spec) where++import Data.Dynamic+import GHC.Generics+import Test.Hspec++import Eventful.Serializer+import Eventful.TH.SumTypeSerializer++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/Eventful/TH/SumTypeSpec.hs view
@@ -0,0 +1,21 @@+module Eventful.TH.SumTypeSpec (spec) where++import Test.Hspec++import Eventful.TH.SumType++data EventA = EventA deriving (Show, Eq)+data EventB = EventB deriving (Show, Eq)+data EventC = EventC deriving (Show, Eq)++mkSumType' "MyEvent" [''EventA, ''EventB, ''EventC]++deriving instance Show MyEvent+deriving instance Eq MyEvent++spec :: Spec+spec = do+  describe "mkSumType" $ do+    it "can create events" $ do+      -- The real utility in this test is the fact that it compiles+      length [EventA' EventA, EventB' EventB, EventC' EventC] `shouldBe` 3
+ tests/HLint.hs view
@@ -0,0 +1,21 @@+module Main (main) where++import Language.Haskell.HLint (hlint)+import System.Exit (exitFailure, exitSuccess)++import Prelude (String, IO, null)++arguments :: [String]+arguments =+  [ "src"+  , "tests"+  , "-i=Redundant do"+  , "-i=Unused LANGUAGE pragma" -- This fails on DeriveGeneric+  , "-i=Use newtype instead of data"+  , "-i=Eta reduce"+  ]++main :: IO ()+main = do+    hints <- hlint arguments+    if null hints then exitSuccess else exitFailure
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}