eventsource-stub-store (empty) → 1.0.0

raw patch · 11 files changed

+524/−0 lines, 11 filesdep +basedep +containersdep +eventsource-apisetup-changed

Dependencies added: base, containers, eventsource-api, eventsource-store-specs, eventsource-stub-store, mtl, protolude, stm, tasty, tasty-hspec

Files

• CHANGELOG.md +7/−0
• LICENSE.md +34/−0
• README.md +5/−0
• Setup.hs +7/−0
• eventsource-stub-store.cabal +62/−0
• library/EventSource/Store/Stub.hs +207/−0
• package.yaml +46/−0
• stack.yaml +66/−0
• test-suite/Main.hs +21/−0
• test-suite/Test/EventSource/Event.hs +37/−0
• test-suite/Test/EventSource/Store/Stub.hs +32/−0

@@ -0,0 +1,7 @@+# Change log++stub-store uses [Semantic Versioning][].+The change log is available through the [releases on GitHub][].++[Semantic Versioning]: http://semver.org/spec/v2.0.0.html+[releases on GitHub]: https://github.com/githubuser/stub-store/releases

@@ -0,0 +1,34 @@+[The BSD-3 License (BSD3)][]++Copyright (c) 2016, Yorick Laupa++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yorick Laupa nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++[The BSD-3 License (BSD3)]: https://opensource.org/licenses/BSD-3-Clause

@@ -0,0 +1,5 @@+# [eventsource-stub-store][]++In-memory `Store` implementation. Meant for testing purpose, so don't expect crazy performance.++[eventsource-stub-store]: https://github.com/YoEight/eventsource-api

@@ -0,0 +1,7 @@+-- This script is used to build and install your package. Typically you don't+-- need to change it. The Cabal documentation has more information about this+-- file: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain

@@ -0,0 +1,62 @@+-- This file has been generated from package.yaml by hpack version 0.15.0.+--+-- see: https://github.com/sol/hpack++name:           eventsource-stub-store+version:        1.0.0+synopsis:       An in-memory stub store implementation.+description:    An in-memory stub store implementation.+category:       Eventsourcing+homepage:       https://github.com/YoEight/eventsource-api#readme+bug-reports:    https://github.com/YoEight/eventsource-api/issues+author:         Yorick Laupa+maintainer:     yo.eight@gmail.com+license:        BSD3+license-file:   LICENSE.md+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    CHANGELOG.md+    LICENSE.md+    package.yaml+    README.md+    stack.yaml++source-repository head+  type: git+  location: https://github.com/YoEight/eventsource-api++library+  hs-source-dirs:+      library+  default-extensions: NoImplicitPrelude+  ghc-options: -Wall+  build-depends:+      base >=4.9 && <5+    , eventsource-api ==1.*+    , protolude >=0.1.10 && <0.2+    , containers+    , mtl+    , stm+  exposed-modules:+      EventSource.Store.Stub+  default-language: Haskell2010++test-suite eventsource-stub-store-test-suite+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      test-suite+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base+    , eventsource-store-specs ==1.*+    , eventsource-stub-store+    , tasty+    , tasty-hspec+    , protolude+  other-modules:+      Test.EventSource.Event+      Test.EventSource.Store.Stub+  default-language: Haskell2010

@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+--------------------------------------------------------------------------------+-- |+-- Module : EventSource.Store.Stub+-- Copyright : (C) 2016 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+-- This module exposes an implementation of Store for testing purpose.+-- This implementation is threadsafe.+--------------------------------------------------------------------------------+module EventSource.Store.Stub+  ( Stream(..)+  , StubStore+  , newStub+  , streams+  , subscriptionIds+  , lastStreamEvent+  ) where++--------------------------------------------------------------------------------+import Control.Concurrent.STM+import qualified Data.Map.Strict as M+import Data.Sequence (Seq, (|>))+import qualified Data.Sequence as S+import Protolude++--------------------------------------------------------------------------------+import EventSource.Store+import EventSource.Types hiding (singleton)++--------------------------------------------------------------------------------+-- | Holds stream state data.+data Stream =+  Stream { streamNextNumber :: EventNumber+         , streamEvents :: Seq SavedEvent+         }++--------------------------------------------------------------------------------+type Sub = TChan SavedEvent+type Subs = Map SubscriptionId Sub++--------------------------------------------------------------------------------+data StubStore =+  StubStore { _streams :: TVar (Map StreamName Stream)+            , _subs :: TVar (Map StreamName Subs)+            }++--------------------------------------------------------------------------------+-- | Creates a new stub event store.+newStub :: IO StubStore+newStub = StubStore <$> newTVarIO mempty <*> newTVarIO mempty++--------------------------------------------------------------------------------+-- | Returns current 'StubStore' streams state.+streams :: StubStore -> IO (Map StreamName Stream)+streams StubStore{..} = readTVarIO _streams++--------------------------------------------------------------------------------+-- | Returns the last event of stream.+lastStreamEvent :: StubStore -> StreamName -> IO (Maybe SavedEvent)+lastStreamEvent stub name = do+  streamMap <- streams stub+  return (go =<< M.lookup name streamMap)+    where+      go stream =+        case S.viewr $ streamEvents stream of+          S.EmptyR -> Nothing+          _ S.:> e -> Just e++--------------------------------------------------------------------------------+-- | Returns all subscriptions a stream has.+subscriptionIds :: StubStore -> StreamName -> IO [SubscriptionId]+subscriptionIds StubStore{..} name = do+  subMap <- readTVarIO _subs+  case M.lookup name subMap of+    Nothing -> return []+    Just subs -> return $ M.keys subs++--------------------------------------------------------------------------------+appendStream :: [Event] -> Stream -> Stream+appendStream = flip $ foldl' go+  where+    go s e =+      let num = streamNextNumber s+          evts = streamEvents s in+      s { streamNextNumber = num + 1+        , streamEvents = evts |> SavedEvent num e+        }++--------------------------------------------------------------------------------+newStream :: [Event] -> Stream+newStream xs = appendStream xs (Stream 0 mempty)++--------------------------------------------------------------------------------+notifySubs :: StubStore -> StreamName -> [SavedEvent] -> STM ()+notifySubs StubStore{..} name events = do+  subMap <- readTVar _subs+  for_ (M.lookup name subMap) $ \subs ->+    for_ subs $ \sub ->+      for_ events $ \e ->+        writeTChan sub e++--------------------------------------------------------------------------------+buildEvent :: (EncodeEvent a, MonadIO m) => a -> m Event+buildEvent a = do+  eid <- freshEventId+  let start = Event { eventType = ""+                    , eventId = eid+                    , eventPayload = dataFromBytes ""+                    , eventMetadata = Nothing+                    }++  return $ execState (encodeEvent a) start++--------------------------------------------------------------------------------+instance Store StubStore where+  appendEvents self@StubStore{..} name ver xs = do+    events <- traverse buildEvent xs+    liftIO $ async $ atomically $ do+      streamMap <- readTVar _streams++      case M.lookup name streamMap of+        Nothing -> do+          case ver of+            StreamExists ->+              throwSTM $ ExpectedVersionException ver NoStream+            ExactVersion v ->+              unless (v == 0) $ throwSTM+                              $ ExpectedVersionException ver NoStream+            _ -> return ()++          let _F Nothing  = Just $ newStream events+              _F (Just s) = Just $ appendStream events s++              newStreamMap = M.alter _F name streamMap++          writeTVar _streams newStreamMap++          -- This part is already performed in 'appendStream' but difficult+          -- to take its logic apart from building 'SavedEvent's.+          let saved = uncurry SavedEvent <$> zip [0..] events+          notifySubs self name saved+          let Just last = getLast $ foldMap (Last . Just) saved+              nextNum = eventNumber last + 1+          return nextNum+++        Just stream -> do+          let currentNumber = streamNextNumber stream+          case ver of+            NoStream ->+              throwSTM $ ExpectedVersionException ver StreamExists+            ExactVersion v ->+              unless (v == streamNextNumber stream - 1)+                $ throwSTM+                $ ExpectedVersionException ver (ExactVersion currentNumber)++            _ -> return ()++          let nextStream = appendStream events stream+              newStreamMap = M.adjust (const nextStream) name streamMap++          writeTVar _streams newStreamMap++          -- This part is already performed in 'appendStream' but difficult+          -- to take its logic apart from building 'SavedEvent's.+          let saved = uncurry SavedEvent <$> zip [currentNumber..] events+          notifySubs self name saved+          let Just last = getLast $ foldMap (Last . Just) saved+              nextNum = eventNumber last + 1+          return nextNum+++  readBatch StubStore{..} name (Batch from _) = liftIO $ async $ atomically $ do+    streamMap <- readTVar _streams+    case M.lookup name streamMap of+      Nothing -> return $ ReadFailure StreamNotFound+      Just stream -> do+        let events = S.filter ((>= from) . eventNumber) $ streamEvents stream+            slice = Slice { sliceEvents = toList events+                          , sliceEndOfStream = True+                          , sliceNextEventNumber = streamNextNumber stream+                          }++        return $ ReadSuccess slice++  subscribe StubStore{..} name = do+    sid <- freshSubscriptionId+    liftIO $ atomically $ do+      chan <- newTChan+      let sub = Subscription sid $ liftIO $ atomically $ do+            saved <- readTChan chan+            return $ Right saved++      subMap <- readTVar _subs+      let _F Nothing  = Just $ M.singleton sid  chan+          _F (Just m) = Just $ M.insert sid chan m++          nextSubMap = M.alter _F name subMap++      writeTVar _subs nextSubMap+      return sub

@@ -0,0 +1,46 @@+# This YAML file describes your package. Stack will automatically generate a+# Cabal file when you run `stack build`. See the hpack website for help with+# this file: <https://github.com/sol/hpack>.+category: Eventsourcing+description: An in-memory stub store implementation.+extra-source-files:+- CHANGELOG.md+- LICENSE.md+- package.yaml+- README.md+- stack.yaml+ghc-options: -Wall+github: YoEight/eventsource-api+library:+  default-extensions:+    - NoImplicitPrelude+  dependencies:+  - base >=4.9 && <5+  - eventsource-api ==1.*+  - protolude >=0.1.10 && <0.2+  - containers+  - mtl+  - stm+  source-dirs: library+license: BSD3+license-file: LICENSE.md+author: Yorick Laupa+maintainer: yo.eight@gmail.com+name: eventsource-stub-store+synopsis: An in-memory stub store implementation.+tests:+  eventsource-stub-store-test-suite:+    dependencies:+    - base+    - eventsource-store-specs ==1.*+    - eventsource-stub-store+    - tasty+    - tasty-hspec+    - protolude+    ghc-options:+    - -rtsopts+    - -threaded+    - -with-rtsopts=-N+    main: Main.hs+    source-dirs: test-suite+version: '1.0.0'

@@ -0,0 +1,66 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# http://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+# resolver: ghcjs-0.1.0_ghc-7.10.2+# resolver:+#  name: custom-snapshot+#  location: "./custom-snapshot.yaml"+resolver: lts-7.14++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+# - location:+#    git: https://github.com/commercialhaskell/stack.git+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a+#   extra-dep: true+#  subdirs:+#  - auto-update+#  - wai+#+# A package marked 'extra-dep: true' will only be built if demanded by a+# non-dependency (i.e. a user package), and its test suites and benchmarks+# will not be run. This is useful for tweaking upstream packages.+packages:+- '.'+# Dependency packages to be pulled from upstream that are not in the resolver+# (e.g., acme-missiles-0.3)+extra-deps: []++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=1.2"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor

@@ -0,0 +1,21 @@+--------------------------------------------------------------------------------+-- |+-- Module : Main+-- Copyright : (C) 2016 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+import qualified Test.Tasty++--------------------------------------------------------------------------------+import qualified Test.EventSource.Store.Stub as Stub++--------------------------------------------------------------------------------+main :: IO ()+main = do+    tree <- sequence [ Stub.test ]+    Test.Tasty.defaultMain (Test.Tasty.testGroup "EventSource API" tree)

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+--------------------------------------------------------------------------------+-- |+-- Module : Test.EventSource.Event+-- Copyright : (C) 2016 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Test.EventSource.Event where++--------------------------------------------------------------------------------+import ClassyPrelude+import Data.Aeson.Types+import EventSource++--------------------------------------------------------------------------------+newtype TestEvent = TestEvent Int deriving (Eq, Show)++--------------------------------------------------------------------------------+instance EncodeEvent TestEvent where+  encodeEvent (TestEvent v) = do+    setEventType "test-event"+    setEventPayload $ dataFromJson $ object [ "value" .= v ]++--------------------------------------------------------------------------------+instance DecodeEvent TestEvent where+  decodeEvent Event{..} = do+    unless (eventType == "test-event") $+      Left "Wrong event type"++    dataAsParse eventPayload $ withObject "" $ \o ->+      fmap TestEvent (o .: "value")

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+--------------------------------------------------------------------------------+-- |+-- Module : Test.EventSource.Store.Stub+-- Copyright : (C) 2016 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Test.EventSource.Store.Stub (test) where++--------------------------------------------------------------------------------+import EventSource.Store.Stub+import Test.Tasty (TestTree)+import Test.Tasty.Hspec++--------------------------------------------------------------------------------+import Test.EventSource.Store.Specification++--------------------------------------------------------------------------------+test :: IO TestTree+test = testSpec "Store Stub" spec++--------------------------------------------------------------------------------+spec :: Spec+spec = parallel $ do+  stub <- runIO newStub+  specification stub