eventful-memory (empty) → 0.1.0

raw patch · 9 files changed

+268/−0 lines, 9 filesdep +HUnitdep +asyncdep +base

Dependencies added: HUnit, async, base, containers, eventful-core, eventful-test-helpers, hlint, hspec, mtl, safe, stm

Files

• CHANGELOG.md +0/−0
• LICENSE.md +19/−0
• README.md +1/−0
• eventful-memory.cabal +84/−0
• src/Eventful/ReadModel/Memory.hs +34/−0
• src/Eventful/Store/Memory.hs +69/−0
• tests/Eventful/Store/MemorySpec.hs +41/−0
• tests/HLint.hs +19/−0
• tests/Spec.hs +1/−0

@@ -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.

@@ -0,0 +1,1 @@+# Eventful memory

@@ -0,0 +1,84 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name:           eventful-memory+version:        0.1.0+synopsis:       In-memory implementations for eventful+description:    In-memory implementations 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 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+    , stm+  exposed-modules:+      Eventful.ReadModel.Memory+      Eventful.Store.Memory+  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 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+    , stm+    , hspec+    , HUnit+    , eventful-test-helpers+  other-modules:+      Eventful.Store.MemorySpec+      HLint+      Eventful.ReadModel.Memory+      Eventful.Store.Memory+  default-language: Haskell2010++test-suite style+  type: exitcode-stdio-1.0+  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+    , stm+    , hlint+  other-modules:+      Eventful.Store.MemorySpec+      Spec+  default-language: Haskell2010

@@ -0,0 +1,34 @@+module Eventful.ReadModel.Memory+  ( memoryReadModel+  ) where++import Control.Concurrent.STM+import Control.Monad.IO.Class+import Safe (maximumDef)++import Eventful.ReadModel.Class+import Eventful.Store.Class++data MemoryReadModelData modeldata+  = MemoryReadModelData+  { memoryReadModelDataLatestSequenceNumber :: SequenceNumber+  , _memoryReadModelDataValue :: modeldata+  } deriving (Show)++-- | Creates a read model that wraps some pure data in a TVar and manages the+-- latest sequence number for you.+memoryReadModel+  :: (MonadIO m)+  => modeldata+  -> (modeldata -> [GloballyOrderedEvent (StoredEvent serialized)] -> m modeldata)+  -> IO (ReadModel (TVar (MemoryReadModelData modeldata)) serialized m)+memoryReadModel initialValue handleEvents = do+  tvar <- newTVarIO $ MemoryReadModelData (-1) initialValue+  return $ ReadModel tvar getLatestSequence handleTVarEvents+  where+    getLatestSequence tvar' = liftIO $ memoryReadModelDataLatestSequenceNumber <$> readTVarIO tvar'+    handleTVarEvents tvar' events = do+      (MemoryReadModelData latestSeq modelData) <- liftIO $ readTVarIO tvar'+      let latestSeq' = maximumDef latestSeq (globallyOrderedEventSequenceNumber <$> events)+      modelData' <- handleEvents modelData events+      liftIO . atomically . writeTVar tvar' $ MemoryReadModelData latestSeq' modelData'

@@ -0,0 +1,69 @@+module Eventful.Store.Memory+  ( memoryEventStore+  , module Eventful.Store.Class+  ) where++import Control.Concurrent.STM+import Data.Foldable (toList)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq, (><))+import qualified Data.Sequence as Seq++import Eventful.Store.Class+import Eventful.UUID++data EventMap serialized+  = EventMap+  { _eventMapUuidMap :: Map UUID (Seq (GloballyOrderedEvent (StoredEvent serialized)))+  , _eventMapSeqNum :: SequenceNumber+  -- TODO: Add projection cache here+  }+  deriving (Show)++-- | 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)+  let+    getLatestVersion uuid = flip latestEventVersion uuid <$> readTVar tvar+    getEvents uuid vers = toList . (\s -> lookupEventsFromVersion s uuid vers) <$> 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{..})++memoryEventStoreGetAllUuids :: TVar (EventMap serialized) -> STM [UUID]+memoryEventStoreGetAllUuids tvar = fmap fst . Map.toList . _eventMapUuidMap <$> readTVar tvar++lookupEventMapRaw :: EventMap serialized -> UUID -> Seq (StoredEvent serialized)+lookupEventMapRaw (EventMap uuidMap _) uuid =+   fmap globallyOrderedEventEvent $ 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++latestEventVersion :: EventMap serialized -> UUID -> EventVersion+latestEventVersion store uuid = EventVersion $ Seq.length (lookupEventMapRaw store uuid) - 1++lookupEventMapSeq :: EventMap serialized -> SequenceNumber -> [GloballyOrderedEvent (StoredEvent serialized)]+lookupEventMapSeq (EventMap uuidMap _) seqNum =+  sortOn globallyOrderedEventSequenceNumber $+  filter ((> seqNum) . globallyOrderedEventSequenceNumber) $+  concat $+  toList <$> toList uuidMap++storeEventMap+  :: EventMap serialized -> UUID -> [serialized] -> EventMap serialized+storeEventMap store@(EventMap uuidMap seqNum) uuid events =+  let+    versStart = latestEventVersion store uuid + 1+    storedEvents = zipWith GloballyOrderedEvent [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

@@ -0,0 +1,41 @@+module Eventful.Store.MemorySpec (spec) where++import Control.Concurrent.STM+import Test.Hspec++import Eventful.Serializer+import Eventful.Store.Memory+import Eventful.TestHelpers++spec :: Spec+spec = do+  describe "TVar memory event store with Dynamic serialized type" $ do+    eventStoreSpec makeDynamicStore (const atomically)+    sequencedEventStoreSpec makeDynamicGlobalStore (const atomically)++  describe "TVar memory event store with actual event type" $ do+    eventStoreSpec makeStore (const atomically)+    sequencedEventStoreSpec makeGlobalStore (const atomically)++makeStore :: IO (MemoryEventStore serialized, ())+makeStore = do+  (store, _, ()) <- makeGlobalStore+  return (store, ())++makeGlobalStore :: IO (MemoryEventStore serialized, GloballyOrderedMemoryEventStore serialized, ())+makeGlobalStore = do+  (store, globalStore) <- memoryEventStore+  return (store, globalStore, ())++makeDynamicStore :: IO (MemoryEventStore CounterEvent, ())+makeDynamicStore = do+  (store, _, ()) <- makeDynamicGlobalStore+  return (store, ())++makeDynamicGlobalStore :: IO (MemoryEventStore CounterEvent, GloballyOrderedMemoryEventStore CounterEvent, ())+makeDynamicGlobalStore = do+  (store, globalStore) <- memoryEventStore+  let+    store' = serializedEventStore dynamicSerializer store+    globalStore' = serializedGloballyOrderedEventStore dynamicSerializer globalStore+  return (store', globalStore', ())

@@ -0,0 +1,19 @@+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+    ]++main :: IO ()+main = do+    hints <- hlint arguments+    if null hints then exitSuccess else exitFailure

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}