diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +1.1.0 +===== + * Add Aggregate API specifications. + 1.0.1 ===== * Fix Stackage build. diff --git a/eventsource-store-specs.cabal b/eventsource-store-specs.cabal --- a/eventsource-store-specs.cabal +++ b/eventsource-store-specs.cabal @@ -1,9 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.17.1. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: a73245d0b01b4f489e3877e705b0ec44226d71819dfeb9e1e05bf013a17152ea name: eventsource-store-specs -version: 1.0.1 +version: 1.1.0 synopsis: Provides common test specification for Store implementation. description: Provides common test specification for Store implementation. category: Eventsourcing, Testing @@ -21,7 +23,6 @@ LICENSE.md package.yaml README.md - stack.yaml source-repository head type: git @@ -30,17 +31,20 @@ library hs-source-dirs: library - default-extensions: NoImplicitPrelude ghc-options: -Wall build-depends: - base >=4.9 && <5 - , protolude >= 0.1.10 && <0.3 + aeson + , async + , base >=4.9 && <5 , eventsource-api ==1.* + , mtl , tasty , tasty-hspec - , mtl - , aeson + , text + , transformers-base , uuid exposed-modules: Test.EventSource.Store.Specification + other-modules: + Paths_eventsource_store_specs default-language: Haskell2010 diff --git a/library/Test/EventSource/Store/Specification.hs b/library/Test/EventSource/Store/Specification.hs --- a/library/Test/EventSource/Store/Specification.hs +++ b/library/Test/EventSource/Store/Specification.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | -- Module : Test.EventSource.Store.Specification @@ -15,16 +17,24 @@ module Test.EventSource.Store.Specification (specification) where -------------------------------------------------------------------------------- -import Prelude (Show(..)) +import Control.Exception (Exception, toException, fromException) +import Control.Monad (unless) +import Data.Foldable (for_, traverse_) +import Data.Semigroup ((<>)) -------------------------------------------------------------------------------- -import Control.Monad.Except -import Data.Aeson.Types -import Data.UUID -import Data.UUID.V4 -import EventSource -import Protolude hiding (show) -import Test.Tasty.Hspec +import Control.Concurrent.Async (wait) +import Control.Monad.Except (runExceptT, mapExceptT) +import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.State (evalStateT, get, modify) +import Data.Aeson.Types (object, withObject, (.=), (.:)) +import Data.Text (Text) +import Data.UUID (toText) +import Data.UUID.V4 (nextRandom) +import EventSource +import EventSource.Aggregate (StreamId(..)) +import qualified EventSource.Aggregate.Simple as Simple +import Test.Tasty.Hspec -------------------------------------------------------------------------------- newtype TestEvent = TestEvent Int deriving (Eq, Show) @@ -45,10 +55,42 @@ fmap TestEvent (o .: "value") -------------------------------------------------------------------------------- -freshStreamName :: MonadIO m => m StreamName -freshStreamName = liftIO $ fmap (StreamName . toText) nextRandom +newtype Test = Test Int deriving (Eq, Show) -------------------------------------------------------------------------------- +data TestCmd + = TestIncr Int + | TestCmdError + +-------------------------------------------------------------------------------- +data TestError = TestError deriving (Eq, Show) + +-------------------------------------------------------------------------------- +instance Exception TestError + +-------------------------------------------------------------------------------- +newtype TestId = TestId Text + +-------------------------------------------------------------------------------- +instance StreamId TestId where + toStreamName (TestId i) = StreamName $ "test:stream:" <> i + +-------------------------------------------------------------------------------- +instance Simple.AggregateIO TestEvent Test where + applyIO (Test x) (TestEvent i) = pure (Test (x+i)) + +-------------------------------------------------------------------------------- +instance Simple.ValidateIO TestCmd TestEvent Test where + validateIO _ cmd = + case cmd of + TestIncr i -> pure (Right $ TestEvent i) + TestCmdError -> pure (Left $ toException TestError) + +-------------------------------------------------------------------------------- +freshStreamName :: MonadBase IO m => m StreamName +freshStreamName = liftBase $ fmap (StreamName . toText) nextRandom + +-------------------------------------------------------------------------------- incr :: Int -> Int incr = (+1) @@ -147,7 +189,7 @@ let values = [0..9] events = fmap TestEvent values seed = Right (0, EventNumber 0) - + testFold (Left e) _ = Left e testFold (Right (a, n)) saved = let n' = eventNumber saved @@ -155,7 +197,7 @@ case ee of Left t -> Left t Right (TestEvent a') -> Right (a + a', max n n') - + name <- freshStreamName _ <- wait =<< appendEvents store name AnyVersion events @@ -177,3 +219,55 @@ got <- iteratorReadAllEvents i got `shouldBe` events + + specify "API/Aggregate - submit event" $ do + agg <- Simple.newAgg (toStore store) (TestId "submit:event") (Test 0) + let events = replicate 10 (TestEvent 1) + + traverse_ (Simple.submitEvt agg) events + got <- Simple.snapshot agg + + got `shouldBe` Test 10 + + specify "API/Aggregate - submit commands" $ do + agg <- Simple.newAgg (toStore store) (TestId "submit:command") (Test 0) + + res1 <- Simple.submitCmd agg (TestIncr 1) + let go1 (Right evt) = evt == TestEvent 1 + go1 Left{} = False + res1 `shouldSatisfy` go1 + + s1 <- Simple.snapshot agg + s1 `shouldBe` Test 1 + + res2 <- Simple.submitCmd agg TestCmdError + let go2 Right{} = False + go2 (Left e) = fromException e == Just TestError + res2 `shouldSatisfy` go2 + + specify "API/Aggregate - loading" $ do + agg1 <- Simple.newAgg (toStore store) (TestId "submit:load") (Test 0) + + let commands = replicate 10 (TestIncr 1) + + traverse_ (Simple.submitCmd agg1) commands + + res1 <- Simple.snapshot agg1 + res1 `shouldBe` Test 10 + + outcome <- Simple.loadAgg (toStore store) (TestId "submit:load") (Test 0) + + case outcome of + Left{} -> error "We should be able to load an aggregate." + Right agg2 -> + do res2 <- Simple.snapshot agg2 + res2 `shouldBe` res1 + + res3 <- Simple.submitCmd agg2 (TestIncr 1) + let go3 Left{} = False + go3 Right{} = True + res3 `shouldSatisfy` go3 + + res4 <- Simple.snapshot agg2 + res4 `shouldBe` Test 11 + diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -8,21 +8,20 @@ - LICENSE.md - package.yaml - README.md -- stack.yaml ghc-options: -Wall github: YoEight/eventsource-api library: - default-extensions: - - NoImplicitPrelude dependencies: - base >=4.9 && <5 - - protolude >= 0.1.10 && <0.3 - eventsource-api ==1.* - tasty - tasty-hspec - mtl - aeson - uuid + - async + - transformers-base + - text source-dirs: library license: BSD3 license-file: LICENSE.md @@ -30,4 +29,4 @@ maintainer: yo.eight@gmail.com name: eventsource-store-specs synopsis: Provides common test specification for Store implementation. -version: '1.0.1' +version: '1.1.0' diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,67 +0,0 @@ -# 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: nightly-2017-08-15 -compiler: ghc-8.2.1 - -# 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