eventful-memory 0.1.2 → 0.1.3

raw patch · 6 files changed

+295/−58 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• eventful-memory.cabal +7/−1
• src/Eventful/ProjectionCache/Memory.hs +62/−0
• src/Eventful/Store/Memory.hs +79/−24
• tests/Eventful/ProjectionCache/MemorySpec.hs +54/−0
• tests/Eventful/Store/MemorySpec.hs +44/−33
• tests/MemoryTestImport.hs +49/−0

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           eventful-memory-version:        0.1.2+version:        0.1.3 synopsis:       In-memory implementations for eventful description:    In-memory implementations for eventful category:       Database,Eventsourcing@@ -36,6 +36,7 @@     , safe     , stm   exposed-modules:+      Eventful.ProjectionCache.Memory       Eventful.ReadModel.Memory       Eventful.Store.Memory   default-language: Haskell2010@@ -58,8 +59,11 @@     , HUnit     , eventful-test-helpers   other-modules:+      Eventful.ProjectionCache.MemorySpec       Eventful.Store.MemorySpec       HLint+      MemoryTestImport+      Eventful.ProjectionCache.Memory       Eventful.ReadModel.Memory       Eventful.Store.Memory   default-language: Haskell2010@@ -79,6 +83,8 @@     , stm     , hlint   other-modules:+      Eventful.ProjectionCache.MemorySpec       Eventful.Store.MemorySpec+      MemoryTestImport       Spec   default-language: Haskell2010

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++module Eventful.ProjectionCache.Memory+  ( ProjectionMap+  , emptyProjectionMap+  , projectionMapTVar+  , tvarProjectionCache+  , embeddedStateProjectionCache+  , module Eventful.ProjectionCache.Types+  ) where++import Control.Concurrent.STM+import Control.Monad.State.Class hiding (state)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Eventful.ProjectionCache.Types++-- | A 'ProjectionMap' just stores the latest snapshot for each UUID.+type ProjectionMap key orderKey serialized = Map key (orderKey, serialized)++emptyProjectionMap :: ProjectionMap key orderKey serialized+emptyProjectionMap = Map.empty++projectionMapTVar :: IO (TVar (ProjectionMap key orderKey serialized))+projectionMapTVar = newTVarIO emptyProjectionMap++storeProjectionInMap+  :: (Ord key)+  => key+  -> orderKey+  -> serialized+  -> ProjectionMap key orderKey serialized+  -> ProjectionMap key orderKey serialized+storeProjectionInMap uuid version state = Map.insert uuid (version, state)++-- | A 'ProjectionCache' that uses a 'TVar' and runs in 'STM'.+tvarProjectionCache+  :: (Ord key)+  => TVar (ProjectionMap key orderKey serialized)+  -> ProjectionCache key orderKey serialized STM+tvarProjectionCache tvar =+  let+    storeProjectionSnapshot uuid version projState = modifyTVar' tvar (storeProjectionInMap uuid version projState)+    loadProjectionSnapshot uuid = Map.lookup uuid <$> readTVar tvar+  in ProjectionCache{..}++-- | A 'ProjectionCache' for some 'MonadState' that contains a 'ProjectionMap'.+embeddedStateProjectionCache+  :: (MonadState s m, Ord key)+  => (s -> ProjectionMap key orderKey serialized)+  -> (s -> ProjectionMap key orderKey serialized -> s)+  -> ProjectionCache key orderKey serialized m+embeddedStateProjectionCache getMap setMap =+  let+    storeProjectionSnapshot uuid version projState = modify' (storeProjectionSnapshot' uuid version projState)+    loadProjectionSnapshot uuid = Map.lookup uuid <$> gets getMap+  in ProjectionCache{..}+  where+    storeProjectionSnapshot' uuid version projState state =+      setMap state $ storeProjectionInMap uuid version projState $ getMap state

@@ -2,11 +2,15 @@ {-# LANGUAGE RecordWildCards #-}  module Eventful.Store.Memory-  ( memoryEventStore+  ( tvarEventStore+  , tvarGloballyOrderedEventStore   , stateEventStore   , stateGloballyOrderedEventStore+  , embeddedStateEventStore+  , embeddedStateGloballyOrderedEventStore   , EventMap   , emptyEventMap+  , eventMapTVar   , module Eventful.Store.Class   ) where @@ -36,58 +40,109 @@ emptyEventMap :: EventMap serialized emptyEventMap = EventMap Map.empty 0 +-- | Initialize an 'EventMap' in a 'TVar'+eventMapTVar :: IO (TVar (EventMap serialized))+eventMapTVar = newTVarIO emptyEventMap+ -- | 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 emptyEventMap+tvarEventStore :: TVar (EventMap serialized) -> EventStore serialized STM+tvarEventStore tvar =   let     getLatestVersion uuid = flip latestEventVersion uuid <$> readTVar tvar-    getEvents uuid vers = toList . (\s -> lookupEventsFromVersion s uuid vers) <$> readTVar tvar+    getEvents uuid range = (\s -> lookupEventsInRange s uuid range) <$> readTVar tvar     storeEvents' uuid events = modifyTVar' tvar (\store -> storeEventMap store uuid events)     storeEvents = transactionalExpectedWriteHelper getLatestVersion storeEvents'-    getSequencedEvents seqNum = flip lookupEventMapSeq seqNum <$> readTVar tvar-  return (EventStore{..}, GloballyOrderedEventStore{..})+  in EventStore{..} --- | An 'EventStore' that runs in a 'MonadState' monad.+-- | Analog of 'tvarEventStore' for a 'GloballyOrderedEventStore'+tvarGloballyOrderedEventStore :: TVar (EventMap serialized) -> GloballyOrderedEventStore serialized STM+tvarGloballyOrderedEventStore tvar =+  let+    getSequencedEvents range = flip lookupEventMapRange range <$> readTVar tvar+  in GloballyOrderedEventStore{..}++-- | Specialized version of 'embeddedStateEventStore' that only contains an+-- 'EventMap' in the state. stateEventStore   :: (MonadState (EventMap serialized) m)   => EventStore serialized m-stateEventStore =+stateEventStore = embeddedStateEventStore id (flip const)++-- | An 'EventStore' that runs on some 'MonadState' that contains an+-- 'EventMap'. This is useful if you want to include other state in your+-- 'MonadState'.+embeddedStateEventStore+  :: (MonadState s m)+  => (s -> EventMap serialized)+  -> (s -> EventMap serialized -> s)+  -> EventStore serialized m+embeddedStateEventStore getMap setMap =   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)+    getLatestVersion uuid = flip latestEventVersion uuid <$> gets getMap+    getEvents uuid range = (\s -> lookupEventsInRange s uuid range) <$> gets getMap+    storeEvents' uuid events = modify' (modifyStore uuid events)     storeEvents = transactionalExpectedWriteHelper getLatestVersion storeEvents'   in EventStore{..}+  where+    modifyStore uuid events state' =+      let+        store = getMap state'+        store' = storeEventMap store uuid events+      in setMap state' store' --- | A 'GloballyOrderedEventStore' that runs in a 'MonadState' monad.+-- | Analogous to 'stateEventStore' for a 'GloballyOrderedEventStore'. stateGloballyOrderedEventStore   :: (MonadState (EventMap serialized) m)   => GloballyOrderedEventStore serialized m-stateGloballyOrderedEventStore =+stateGloballyOrderedEventStore = embeddedStateGloballyOrderedEventStore id++-- | Analogous to 'embeddedStateEventStore' for a 'GloballyOrderedEventStore'.+embeddedStateGloballyOrderedEventStore+  :: (MonadState s m)+  => (s -> EventMap serialized)+  -> GloballyOrderedEventStore serialized m+embeddedStateGloballyOrderedEventStore getMap =   let-    getSequencedEvents seqNum = flip lookupEventMapSeq seqNum <$> get+    getSequencedEvents range = flip lookupEventMapRange range <$> gets getMap   in GloballyOrderedEventStore{..}  lookupEventMapRaw :: EventMap serialized -> UUID -> Seq (StoredEvent serialized) lookupEventMapRaw (EventMap uuidMap _) uuid =   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-lookupEventsFromVersion store uuid (Just (EventVersion vers)) = Seq.drop vers $ lookupEventMapRaw store uuid+lookupEventsInRange :: EventMap serialized -> UUID -> EventStoreQueryRange EventVersion -> [StoredEvent serialized]+lookupEventsInRange store uuid range = filterEventsByRange range' 0 rawEvents+  where+    range' = unEventVersion <$> range+    rawEvents = toList $ lookupEventMapRaw store uuid +filterEventsByRange :: EventStoreQueryRange Int -> Int -> [event] -> [event]+filterEventsByRange EventStoreQueryRange{..} defaultStart events =+  let+    (start', events') =+      case eventStoreQueryRangeStart of+        StartFromBeginning -> (defaultStart, events)+        StartQueryAt start -> (start, drop (start - defaultStart) events)+    events'' =+      case eventStoreQueryRangeLimit of+        NoQueryLimit -> events'+        MaxNumberOfEvents num -> take num events'+        StopQueryAt stop -> take (stop - start' + 1) events'+  in events''+ latestEventVersion :: EventMap serialized -> UUID -> EventVersion latestEventVersion store uuid = EventVersion $ Seq.length (lookupEventMapRaw store uuid) - 1 -lookupEventMapSeq :: EventMap serialized -> SequenceNumber -> [GloballyOrderedEvent serialized]-lookupEventMapSeq (EventMap uuidMap _) seqNum =-  sortOn globallyOrderedEventSequenceNumber $-  filter ((> seqNum) . globallyOrderedEventSequenceNumber) $-  concat $-  toList <$> toList uuidMap+lookupEventMapRange :: EventMap serialized -> EventStoreQueryRange SequenceNumber -> [GloballyOrderedEvent serialized]+lookupEventMapRange (EventMap uuidMap _) range = filterEventsByRange range' 1 rawEvents+  where+    range' = unSequenceNumber <$> range+    rawEvents =+      sortOn globallyOrderedEventSequenceNumber $+      concat $+      toList <$> toList uuidMap  storeEventMap   :: EventMap serialized -> UUID -> [serialized] -> EventMap serialized

@@ -0,0 +1,54 @@+module Eventful.ProjectionCache.MemorySpec (spec) where++import Control.Concurrent.STM+import Control.Monad.State.Strict+import Test.Hspec++import Eventful.ProjectionCache.Memory+import Eventful.Store.Memory+import Eventful.TestHelpers++import MemoryTestImport++spec :: Spec+spec = do+  describe "TVar projection cache" $ do+    streamProjectionCacheSpec tvarStreamProjectionCacheRunner+    globallyOrderedProjectionCacheSpec tvarGloballyOrderedProjectionCacheRunner++  describe "MonadState embedded memory projection cache" $ do+    streamProjectionCacheSpec stateStreamProjectionCacheRunner+    globallyOrderedProjectionCacheSpec stateGloballyOrderedProjectionCacheRunner++tvarStreamProjectionCacheRunner :: StreamProjectionCacheRunner STM+tvarStreamProjectionCacheRunner = StreamProjectionCacheRunner $ \action -> do+  eventTVar <- eventMapTVar+  projTVar <- projectionMapTVar+  let+    store = tvarEventStore eventTVar+    cache = tvarProjectionCache projTVar+  atomically $ action store cache++tvarGloballyOrderedProjectionCacheRunner :: GloballyOrderedProjectionCacheRunner STM+tvarGloballyOrderedProjectionCacheRunner = GloballyOrderedProjectionCacheRunner $ \action -> do+  eventTVar <- eventMapTVar+  projTVar <- projectionMapTVar+  let+    store = tvarEventStore eventTVar+    globalStore = tvarGloballyOrderedEventStore eventTVar+    cache = tvarProjectionCache projTVar+  atomically $ action store globalStore cache++stateStreamProjectionCacheRunner :: StreamProjectionCacheRunner (StateT (StreamEmbeddedState Counter CounterEvent) IO)+stateStreamProjectionCacheRunner = StreamProjectionCacheRunner $ \action -> evalStateT (action store cache) emptyEmbeddedState+  where+    store = embeddedStateEventStore embeddedEventMap setEventMap+    cache = embeddedStateProjectionCache embeddedProjectionMap setProjectionMap++stateGloballyOrderedProjectionCacheRunner :: GloballyOrderedProjectionCacheRunner (StateT (GloballyOrderedEmbeddedState Counter CounterEvent Text) IO)+stateGloballyOrderedProjectionCacheRunner =+  GloballyOrderedProjectionCacheRunner $ \action -> evalStateT (action store globalStore cache) emptyEmbeddedState+  where+    store = embeddedStateEventStore embeddedEventMap setEventMap+    globalStore = embeddedStateGloballyOrderedEventStore embeddedEventMap+    cache = embeddedStateProjectionCache embeddedProjectionMap setProjectionMap

@@ -4,50 +4,61 @@ import Control.Monad.State.Strict import Test.Hspec -import Eventful.Serializer import Eventful.Store.Memory import Eventful.TestHelpers +import MemoryTestImport+ spec :: Spec spec = do-  describe "TVar memory event store with Dynamic serialized type" $ do-    eventStoreSpec makeTVarDynamicStore (const atomically)-    sequencedEventStoreSpec makeTVarDynamicGlobalStore (const atomically)-   describe "TVar memory event store with actual event type" $ do-    eventStoreSpec makeTVarStore (const atomically)-    sequencedEventStoreSpec makeTVarGlobalStore (const atomically)+    eventStoreSpec tvarRunner+    sequencedEventStoreSpec tvarGlobalRunner -  describe "MonadState memory event store with actual event type" $ do-    eventStoreSpec makeStateStore (const (flip evalStateT emptyEventMap))-    sequencedEventStoreSpec makeStateGlobalStore (const (flip evalStateT emptyEventMap))+  describe "TVar memory event store with Dynamic serialized type" $ do+    eventStoreSpec tvarDynamicRunner+    sequencedEventStoreSpec tvarDynamicGlobalRunner -makeTVarStore :: IO (EventStore serialized STM, ())-makeTVarStore = do-  (store, _, ()) <- makeTVarGlobalStore-  return (store, ())+  describe "MonadState memory event store with actual event type" $ do+    eventStoreSpec stateStoreRunner+    sequencedEventStoreSpec stateStoreGlobalRunner -makeTVarGlobalStore :: IO (EventStore serialized STM, GloballyOrderedEventStore serialized STM, ())-makeTVarGlobalStore = do-  (store, globalStore) <- memoryEventStore-  return (store, globalStore, ())+  describe "MonadState embedded memory event store with actual event type" $ do+    eventStoreSpec embeddedStateStoreRunner+    sequencedEventStoreSpec embeddedStateStoreGlobalRunner -makeTVarDynamicStore :: IO (EventStore CounterEvent STM, ())-makeTVarDynamicStore = do-  (store, _, ()) <- makeTVarDynamicGlobalStore-  return (store, ())+tvarRunner :: EventStoreRunner STM+tvarRunner = EventStoreRunner $ \action -> (tvarEventStore <$> eventMapTVar) >>= atomically . action -makeTVarDynamicGlobalStore :: IO (EventStore CounterEvent STM, GloballyOrderedEventStore CounterEvent STM, ())-makeTVarDynamicGlobalStore = do-  (store, globalStore) <- memoryEventStore+tvarGlobalRunner :: GloballyOrderedEventStoreRunner STM+tvarGlobalRunner = GloballyOrderedEventStoreRunner $ \action -> do+  tvar <- eventMapTVar   let-    store' = serializedEventStore dynamicSerializer store-    globalStore' = serializedGloballyOrderedEventStore dynamicSerializer globalStore-  return (store', globalStore', ())+    store = tvarEventStore tvar+    globalStore = tvarGloballyOrderedEventStore tvar+  atomically $ action store globalStore -makeStateStore :: IO (EventStore serialized (StateT (EventMap serialized) IO), ())-makeStateStore = return (stateEventStore, ())+tvarDynamicRunner :: EventStoreRunner STM+tvarDynamicRunner = EventStoreRunner $ \action -> (fst <$> makeDynamicTVarStore) >>= atomically . action -makeStateGlobalStore-  :: IO (EventStore serialized (StateT (EventMap serialized) IO), GloballyOrderedEventStore serialized (StateT (EventMap serialized) IO), ())-makeStateGlobalStore = return (stateEventStore, stateGloballyOrderedEventStore, ())+tvarDynamicGlobalRunner :: GloballyOrderedEventStoreRunner STM+tvarDynamicGlobalRunner = GloballyOrderedEventStoreRunner $ \action -> makeDynamicTVarStore >>= atomically . uncurry action++stateStoreRunner :: EventStoreRunner (StateT (EventMap CounterEvent) IO)+stateStoreRunner = EventStoreRunner $ \action -> evalStateT (action stateEventStore) emptyEventMap++stateStoreGlobalRunner :: GloballyOrderedEventStoreRunner (StateT (EventMap CounterEvent) IO)+stateStoreGlobalRunner = GloballyOrderedEventStoreRunner $+  \action -> evalStateT (action stateEventStore stateGloballyOrderedEventStore) emptyEventMap++embeddedStateStoreRunner :: EventStoreRunner (StateT (StreamEmbeddedState Counter CounterEvent) IO)+embeddedStateStoreRunner = EventStoreRunner $ \action -> evalStateT (action store) emptyEmbeddedState+  where+    store = embeddedStateEventStore embeddedEventMap setEventMap++embeddedStateStoreGlobalRunner :: GloballyOrderedEventStoreRunner (StateT (StreamEmbeddedState Counter CounterEvent) IO)+embeddedStateStoreGlobalRunner = GloballyOrderedEventStoreRunner $+  \action -> evalStateT (action store globalStore) emptyEmbeddedState+  where+    store = embeddedStateEventStore embeddedEventMap setEventMap+    globalStore = embeddedStateGloballyOrderedEventStore embeddedEventMap

@@ -0,0 +1,49 @@+module MemoryTestImport+  ( makeDynamicTVarStore+  , EmbeddedState (..)+  , StreamEmbeddedState+  , GloballyOrderedEmbeddedState+  , emptyEmbeddedState+  , setEventMap+  , setProjectionMap+  ) where++import Control.Concurrent.STM++import Eventful.ProjectionCache.Memory+import Eventful.Serializer+import Eventful.Store.Memory+import Eventful.TestHelpers+import Eventful.UUID++makeDynamicTVarStore :: IO (EventStore CounterEvent STM, GloballyOrderedEventStore CounterEvent STM)+makeDynamicTVarStore = do+  tvar <- eventMapTVar+  let+    store = tvarEventStore tvar+    globalStore = tvarGloballyOrderedEventStore tvar+    store' = serializedEventStore dynamicSerializer store+    globalStore' = serializedGloballyOrderedEventStore dynamicSerializer globalStore+  return (store', globalStore')++data EmbeddedState state event key orderKey+  = EmbeddedState+  { _embeddedDummyArgument :: Int+  , embeddedEventMap :: EventMap event+  , embeddedProjectionMap :: ProjectionMap key orderKey state+  }++type StreamEmbeddedState state event = EmbeddedState state event UUID EventVersion+type GloballyOrderedEmbeddedState state event key = EmbeddedState state event key SequenceNumber++emptyEmbeddedState :: EmbeddedState state event key orderKey+emptyEmbeddedState = EmbeddedState 100 emptyEventMap emptyProjectionMap++setEventMap :: EmbeddedState state event key orderKey -> EventMap event -> EmbeddedState state event key orderKey+setEventMap state' eventMap = state' { embeddedEventMap = eventMap }++setProjectionMap+  :: EmbeddedState state event key orderKey+  -> ProjectionMap key orderKey state+  -> EmbeddedState state event key orderKey+setProjectionMap state' projectionMap = state' { embeddedProjectionMap = projectionMap }