diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/eventsource-stub-store.cabal b/eventsource-stub-store.cabal new file mode 100644 --- /dev/null +++ b/eventsource-stub-store.cabal @@ -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 diff --git a/library/EventSource/Store/Stub.hs b/library/EventSource/Store/Stub.hs new file mode 100644 --- /dev/null +++ b/library/EventSource/Store/Stub.hs @@ -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 +-- 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 diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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: . +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' diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/test-suite/Main.hs b/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/test-suite/Main.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (C) 2016 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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) diff --git a/test-suite/Test/EventSource/Event.hs b/test-suite/Test/EventSource/Event.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/EventSource/Event.hs @@ -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 +-- 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") diff --git a/test-suite/Test/EventSource/Store/Stub.hs b/test-suite/Test/EventSource/Store/Stub.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/EventSource/Store/Stub.hs @@ -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 +-- 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