eventful-memory 0.1.1 → 0.1.2

raw patch · 5 files changed

+68/−27 lines, 5 filesdep −asyncPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: async

API changes (from Hackage documentation)

Files

• eventful-memory.cabal +1/−7
• src/Eventful/ReadModel/Memory.hs +1/−1
• src/Eventful/Store/Memory.hs +39/−5
• tests/Eventful/Store/MemorySpec.hs +26/−14
• tests/HLint.hs +1/−0

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           eventful-memory-version:        0.1.1+version:        0.1.2 synopsis:       In-memory implementations for eventful description:    In-memory implementations for eventful category:       Database,Eventsourcing@@ -27,12 +27,10 @@ library   hs-source-dirs:       src-  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies   ghc-options: -Wall   build-depends:       base >= 4.9 && < 5     , eventful-core-    , async     , containers     , mtl     , safe@@ -48,12 +46,10 @@   hs-source-dirs:       tests       src-  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies   ghc-options: -Wall   build-depends:       base >= 4.9 && < 5     , eventful-core-    , async     , containers     , mtl     , safe@@ -73,12 +69,10 @@   main-is: HLint.hs   hs-source-dirs:       tests-  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies   ghc-options: -Wall   build-depends:       base >= 4.9 && < 5     , eventful-core-    , async     , containers     , mtl     , safe

@@ -20,7 +20,7 @@ memoryReadModel   :: (MonadIO m)   => modeldata-  -> (modeldata -> [GloballyOrderedEvent (StoredEvent serialized)] -> m modeldata)+  -> (modeldata -> [GloballyOrderedEvent serialized] -> m modeldata)   -> IO (ReadModel (TVar (MemoryReadModelData modeldata)) serialized m) memoryReadModel initialValue handleEvents = do   tvar <- newTVarIO $ MemoryReadModelData (-1) initialValue

@@ -1,9 +1,17 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+ module Eventful.Store.Memory   ( memoryEventStore+  , stateEventStore+  , stateGloballyOrderedEventStore+  , EventMap+  , emptyEventMap   , module Eventful.Store.Class   ) where  import Control.Concurrent.STM+import Control.Monad.State.Class import Data.Foldable (toList) import Data.List (sortOn) import Data.Map.Strict (Map)@@ -15,20 +23,25 @@ import Eventful.Store.Class import Eventful.UUID +-- | Internal data structure used for the in-memory event stores. data EventMap serialized   = EventMap-  { _eventMapUuidMap :: Map UUID (Seq (GloballyOrderedEvent (StoredEvent serialized)))+  { _eventMapUuidMap :: Map UUID (Seq (GloballyOrderedEvent serialized))   , _eventMapSeqNum :: SequenceNumber   -- TODO: Add projection cache here   }   deriving (Show) +-- | What it says on the tin, an initialized empty 'EventMap'+emptyEventMap :: EventMap serialized+emptyEventMap = EventMap Map.empty 0+ -- | An 'EventStore' that stores events in a 'TVar' and runs in 'STM'. This -- functions initializes the store by creating the 'TVar' and hooking up the -- event store API to that 'TVar'. memoryEventStore :: IO (EventStore serialized STM, GloballyOrderedEventStore serialized STM) memoryEventStore = do-  tvar <- newTVarIO (EventMap Map.empty 0)+  tvar <- newTVarIO emptyEventMap   let     getLatestVersion uuid = flip latestEventVersion uuid <$> readTVar tvar     getEvents uuid vers = toList . (\s -> lookupEventsFromVersion s uuid vers) <$> readTVar tvar@@ -37,9 +50,30 @@     getSequencedEvents seqNum = flip lookupEventMapSeq seqNum <$> readTVar tvar   return (EventStore{..}, GloballyOrderedEventStore{..}) +-- | An 'EventStore' that runs in a 'MonadState' monad.+stateEventStore+  :: (MonadState (EventMap serialized) m)+  => EventStore serialized m+stateEventStore =+  let+    getLatestVersion uuid = flip latestEventVersion uuid <$> get+    getEvents uuid vers = toList . (\s -> lookupEventsFromVersion s uuid vers) <$> get+    storeEvents' uuid events = modify (\store -> storeEventMap store uuid events)+    storeEvents = transactionalExpectedWriteHelper getLatestVersion storeEvents'+  in EventStore{..}++-- | A 'GloballyOrderedEventStore' that runs in a 'MonadState' monad.+stateGloballyOrderedEventStore+  :: (MonadState (EventMap serialized) m)+  => GloballyOrderedEventStore serialized m+stateGloballyOrderedEventStore =+  let+    getSequencedEvents seqNum = flip lookupEventMapSeq seqNum <$> get+  in GloballyOrderedEventStore{..}+ lookupEventMapRaw :: EventMap serialized -> UUID -> Seq (StoredEvent serialized) lookupEventMapRaw (EventMap uuidMap _) uuid =-   fmap globallyOrderedEventEvent $ fromMaybe Seq.empty $ Map.lookup uuid uuidMap+  fmap globallyOrderedEventToStoredEvent $ fromMaybe Seq.empty $ Map.lookup uuid uuidMap  lookupEventsFromVersion :: EventMap serialized -> UUID -> Maybe EventVersion -> Seq (StoredEvent serialized) lookupEventsFromVersion store uuid Nothing = lookupEventMapRaw store uuid@@ -48,7 +82,7 @@ latestEventVersion :: EventMap serialized -> UUID -> EventVersion latestEventVersion store uuid = EventVersion $ Seq.length (lookupEventMapRaw store uuid) - 1 -lookupEventMapSeq :: EventMap serialized -> SequenceNumber -> [GloballyOrderedEvent (StoredEvent serialized)]+lookupEventMapSeq :: EventMap serialized -> SequenceNumber -> [GloballyOrderedEvent serialized] lookupEventMapSeq (EventMap uuidMap _) seqNum =   sortOn globallyOrderedEventSequenceNumber $   filter ((> seqNum) . globallyOrderedEventSequenceNumber) $@@ -60,7 +94,7 @@ storeEventMap store@(EventMap uuidMap seqNum) uuid events =   let     versStart = latestEventVersion store uuid + 1-    storedEvents = zipWith GloballyOrderedEvent [seqNum + 1..] $ zipWith (StoredEvent uuid) [versStart..] events+    storedEvents = zipWith storedEventToGloballyOrderedEvent [seqNum + 1..] $ zipWith (StoredEvent uuid) [versStart..] events     newMap = Map.insertWith (flip (><)) uuid (Seq.fromList storedEvents) uuidMap     newSeq = seqNum + (SequenceNumber $ length events)   in EventMap newMap newSeq

@@ -1,6 +1,7 @@ module Eventful.Store.MemorySpec (spec) where  import Control.Concurrent.STM+import Control.Monad.State.Strict import Test.Hspec  import Eventful.Serializer@@ -10,32 +11,43 @@ spec :: Spec spec = do   describe "TVar memory event store with Dynamic serialized type" $ do-    eventStoreSpec makeDynamicStore (const atomically)-    sequencedEventStoreSpec makeDynamicGlobalStore (const atomically)+    eventStoreSpec makeTVarDynamicStore (const atomically)+    sequencedEventStoreSpec makeTVarDynamicGlobalStore (const atomically)    describe "TVar memory event store with actual event type" $ do-    eventStoreSpec makeStore (const atomically)-    sequencedEventStoreSpec makeGlobalStore (const atomically)+    eventStoreSpec makeTVarStore (const atomically)+    sequencedEventStoreSpec makeTVarGlobalStore (const atomically) -makeStore :: IO (EventStore serialized STM, ())-makeStore = do-  (store, _, ()) <- makeGlobalStore+  describe "MonadState memory event store with actual event type" $ do+    eventStoreSpec makeStateStore (const (flip evalStateT emptyEventMap))+    sequencedEventStoreSpec makeStateGlobalStore (const (flip evalStateT emptyEventMap))++makeTVarStore :: IO (EventStore serialized STM, ())+makeTVarStore = do+  (store, _, ()) <- makeTVarGlobalStore   return (store, ()) -makeGlobalStore :: IO (EventStore serialized STM, GloballyOrderedEventStore serialized STM, ())-makeGlobalStore = do+makeTVarGlobalStore :: IO (EventStore serialized STM, GloballyOrderedEventStore serialized STM, ())+makeTVarGlobalStore = do   (store, globalStore) <- memoryEventStore   return (store, globalStore, ()) -makeDynamicStore :: IO (EventStore CounterEvent STM, ())-makeDynamicStore = do-  (store, _, ()) <- makeDynamicGlobalStore+makeTVarDynamicStore :: IO (EventStore CounterEvent STM, ())+makeTVarDynamicStore = do+  (store, _, ()) <- makeTVarDynamicGlobalStore   return (store, ()) -makeDynamicGlobalStore :: IO (EventStore CounterEvent STM, GloballyOrderedEventStore CounterEvent STM, ())-makeDynamicGlobalStore = do+makeTVarDynamicGlobalStore :: IO (EventStore CounterEvent STM, GloballyOrderedEventStore CounterEvent STM, ())+makeTVarDynamicGlobalStore = do   (store, globalStore) <- memoryEventStore   let     store' = serializedEventStore dynamicSerializer store     globalStore' = serializedGloballyOrderedEventStore dynamicSerializer globalStore   return (store', globalStore', ())++makeStateStore :: IO (EventStore serialized (StateT (EventMap serialized) IO), ())+makeStateStore = return (stateEventStore, ())++makeStateGlobalStore+  :: IO (EventStore serialized (StateT (EventMap serialized) IO), GloballyOrderedEventStore serialized (StateT (EventMap serialized) IO), ())+makeStateGlobalStore = return (stateEventStore, stateGloballyOrderedEventStore, ())

@@ -11,6 +11,7 @@     , "tests"     , "-i=Redundant do"     , "-i=Unused LANGUAGE pragma" -- This fails on DeriveGeneric+    , "-i=Use section"     ]  main :: IO ()