packages feed

cqrs-testkit (empty) → 0.10.0

raw patch · 13 files changed

+898/−0 lines, 13 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, containers, cqrs-core, deepseq, hspec, io-streams, lifted-base, random, transformers, uuid-types

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2011-2015 Bardur Arantsson++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cqrs-testkit.cabal view
@@ -0,0 +1,39 @@+Name:                cqrs-testkit+Version:             0.10.0+Synopsis:            Command-Query Responsibility Segregation Test Support+Description:         Test Support for CQRS integration components.+License:             MIT+License-file:        LICENSE+Category:            Data+Cabal-version:       >=1.10+Build-type:          Simple+Author:              Bardur Arantsson+Maintainer:          Bardur Arantsson <bardur@scientician.net>++Library+  Build-Depends:       base >= 4.8 && < 5+                     , bytestring >= 0.9.0.1+                     , containers >= 0.5 && < 1+                     , cqrs-core >= 0.10.0 && < 0.11.0+                     , deepseq >= 1.4 && < 2+                     , io-streams >= 1.2 && < 2+                     , lifted-base >= 0.2.3 && < 1+                     , random >= 1.0 && < 2+                     , transformers >= 0.4.1 && < 0.5+                     , uuid-types >= 1.0 && < 1.1+                     -- Test framework+                     , hspec >= 2.2.0 && < 3.0+                     , HUnit >= 1.3 && < 2.0+  Default-language:    Haskell2010+  ghc-options:         -Wall+  hs-source-dirs:      src+  Exposed-modules:     Data.CQRS.Test.TestKit+                       Data.CQRS.Test.Internal.AggregateAction+                       Data.CQRS.Test.Internal.ArchiveStoreUtils+                       Data.CQRS.Test.Internal.ArchiveStoreTest+                       Data.CQRS.Test.Internal.EventStoreTest+                       Data.CQRS.Test.Internal.RepositoryTest+                       Data.CQRS.Test.Internal.Scope+                       Data.CQRS.Test.Internal.SnapshotTest+                       Data.CQRS.Test.Internal.TestKitSettings+                       Data.CQRS.Test.Internal.Utils
+ src/Data/CQRS/Test/Internal/AggregateAction.hs view
@@ -0,0 +1,10 @@+module Data.CQRS.Test.Internal.AggregateAction+    ( byteStringAggregateAction )+    where++import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import           Data.CQRS.Types.AggregateAction++byteStringAggregateAction :: AggregateAction ByteString ByteString+byteStringAggregateAction maybeA e = maybe e (\a -> B.append a e) maybeA
+ src/Data/CQRS/Test/Internal/ArchiveStoreTest.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+module Data.CQRS.Test.Internal.ArchiveStoreTest+    ( mkArchiveStoreSpec+    ) where++import           Control.DeepSeq (NFData)+import           Control.Monad (forM, forM_, replicateM)+import           Control.Monad.Trans.Reader (ask)+import           Control.Monad.IO.Class (liftIO)+import           Data.ByteString (ByteString)+import           Data.CQRS.Query+import           Data.CQRS.Types.ArchiveRef (ArchiveRef(..))+import           Data.CQRS.Types.ArchiveStore (ArchiveStore)+import qualified Data.CQRS.Types.ArchiveStore as AS+import           Data.CQRS.Types.EventStore (EventStore, esStoreEvents)+import           Data.CQRS.Test.Internal.ArchiveStoreUtils (readAllEventsFromArchiveStore)+import           Data.CQRS.Test.Internal.Scope (ScopeM, verify, randomUUID, mkRunScope)+import           Data.CQRS.Test.Internal.TestKitSettings+import           Data.CQRS.Test.Internal.Utils (randomByteString, chunkRandomly)+import           Data.Function (on)+import           Data.List (groupBy, sortBy)+import           Data.UUID.Types (UUID)+import qualified System.IO.Streams.List as SL+import qualified System.Random as R+import qualified Test.Hspec as Hspec+import           Test.Hspec (Expectation, Spec, describe, shouldBe)+import           Test.HUnit (assertBool)++-- Ambient data for test scope for each spec.+data Scope e = Scope { scopeArchiveStore :: ArchiveStore e+                     , scopeEventStore :: EventStore e+                     }++-- | Assert that two event streams are observationally equivalent+-- assuming that events may appear in any order wrt. aggregate ID, as+-- long as they respect the sequence number ordering.+shouldHaveEventsEquivalentTo :: (Eq e, Show e) => [(UUID, PersistedEvent e)] -> [(UUID, PersistedEvent e)] -> Expectation+shouldHaveEventsEquivalentTo actualEvents expectedEvents =+    assertBool message (actualEvents' == expectedEvents')+  where+    message = "Event sequence " ++ show actualEvents ++ " is not (observationally) equivalent to " ++ show expectedEvents+    -- Stable sort of the actualEvents by the aggregate ID.+    actualEvents' = sortBy (compare `on` fst) actualEvents+    -- Stable sort of the given ordering on the expectedEvents.+    expectedEvents' = sortBy (compare `on` fst) expectedEvents++-- Generate a sequence of 'n' events. All the events are generated+-- for the same aggregateId (which is chosen randomly).+generateFixedNumberOfEvents :: Int -> IO [(UUID, PersistedEvent ByteString)]+generateFixedNumberOfEvents n = do+  aggregateId <- R.randomIO+  events <- replicateM n generateEvent+  uuids <- replicateM n R.randomIO+  let persistedEvents = map (\(e, s, u) -> PersistedEvent e s u) $ zip3 events [0..] uuids+  return $ zip (repeat aggregateId) persistedEvents+  where+    generateEvent :: IO ByteString+    generateEvent = randomByteString 8++-- Store given events in exactly the order given.+storeEvents :: UUID -> [PersistedEvent e] -> ScopeM (Scope e) ()+storeEvents aggregateId events = do+  eventStore <- fmap scopeEventStore ask+  liftIO $ (esStoreEvents eventStore) aggregateId events++verifyArchives :: (Show e, Eq e) => Int -> [(UUID, PersistedEvent e)] -> ScopeM (Scope e) ()+verifyArchives expectedArchiveCount expectedPersistedEvents = do+  (archiveCount, persistedEvents) <- readAllEventsFromArchiveStore scopeArchiveStore+  verify $ do+    archiveCount `shouldBe` expectedArchiveCount+    persistedEvents `shouldHaveEventsEquivalentTo` expectedPersistedEvents++readArchive :: ArchiveRef -> ScopeM (Scope e) [(UUID, PersistedEvent e)]+readArchive archiveRef = do+  archiveStore <- fmap scopeArchiveStore ask+  liftIO $ (AS.asReadArchive archiveStore) archiveRef SL.toList++archiveEvents :: Int -> ScopeM (Scope e) (Maybe UUID)+archiveEvents archiveSize = do+  archiveStore <- fmap scopeArchiveStore ask+  liftIO $ (AS.asArchiveEvents archiveStore) archiveSize++rotateArchives :: Int -> ScopeM (Scope e) ()+rotateArchives archiveSize = do+  archiveStore <- fmap scopeArchiveStore ask+  liftIO $ (AS.rotateArchives archiveStore) archiveSize++-- Write out events from a given list in a randomized fashion.+storeEventsRandomized :: [(UUID, PersistedEvent e)] -> ScopeM (Scope e) ()+storeEventsRandomized events = do+    -- Chunk into random number of randomly sized batches.+    batches <- liftIO $ do+                 nChunks <- R.getStdRandom $ R.randomR (0, length events - 1)+                 chunkRandomly nChunks events+    -- Write each batch+    forM_ batches $ writeBatch+  where+    writeBatch batch = do+      -- Group by aggregate ID so we don't just write a single event at a time.+      let eventsByAggregateId = groupBy (\x y -> fst x == fst y) batch+      -- Write each group in a single call.+      forM_ eventsByAggregateId $ \eventGroup -> do+        let aggregateId = fst $ head eventGroup+        storeEvents aggregateId $ map snd eventGroup++-- Given test kit settings, create the full spec for testing the+-- archive store implementation against those settings.+mkArchiveStoreSpec :: TestKitSettings a (ArchiveStore ByteString, EventStore ByteString) -> Spec+mkArchiveStoreSpec testKitSettings = do++  describe "ArchiveStore.enumerateAllEvents " $ do++    it "basic enumeration should work" $ do+      -- Setup+      aggregateId <- randomUUID+      eventId0 <- randomUUID+      eventId1 <- randomUUID+      eventId2 <- randomUUID+      let expectedEvents = [ (aggregateId, PersistedEvent "3" 0 eventId0)+                           , (aggregateId, PersistedEvent "6" 1 eventId1)+                           , (aggregateId, PersistedEvent "9" 2 eventId2)+                           ]+      let expectedEvents' = map snd expectedEvents+      storeEvents aggregateId expectedEvents'+      -- Exercise+      (_, es) <- readAllEventsFromArchiveStore scopeArchiveStore+      -- Verify+      verify $ es `shouldHaveEventsEquivalentTo` expectedEvents++    it "enumeration for multiple aggregates should work" $ do+      -- Setup+      aggregateId0 <- randomUUID+      aggregateId1 <- randomUUID+      aggregateId2 <- randomUUID+      gpes0_0 <- genEvents aggregateId0 4 0+      gpes1_0 <- genEvents aggregateId1 5 0+      gpes0_1 <- genEvents aggregateId0 3 (0 + length gpes0_0)+      gpes2_0 <- genEvents aggregateId2 90 0+      gpes1_1 <- genEvents aggregateId1 5 (0 + length gpes1_0)+      -- Exercise+      (_, es) <- readAllEventsFromArchiveStore scopeArchiveStore+      -- Verify: All events are there and are in the correct order+      -- wrt. each individual aggregate.+      let gpes = concat [ gpes0_0, gpes0_1, gpes1_0, gpes1_1, gpes2_0 ]+      verify $ es `shouldHaveEventsEquivalentTo` gpes++  describe "ArciveStore module" $ do++    it "'archiveEvents' should move at most <archiveSize> events to the archive" $ do+      -- Setup+      persistedEvents <- liftIO $ generateFixedNumberOfEvents 6+      storeEventsRandomized persistedEvents+      -- Exercise+      (Just archiveId) <- archiveEvents 5+      -- Verify: Should have one event "left over" in current archive.+      currentArchiveEvents <- readArchive CurrentArchive+      verify $ length currentArchiveEvents `shouldBe` 1+      verify $ currentArchiveEvents `shouldHaveEventsEquivalentTo` (drop 5 $ persistedEvents)+      -- Verify archives (general)+      verifyArchives 1 persistedEvents+      -- Verify created archive+      archivedEvents <- readArchive (NamedArchive archiveId)+      verify $ archivedEvents `shouldHaveEventsEquivalentTo` (take 5 $ persistedEvents)++    it "'archiveEvents' should include all events if the number of events falls on the <archiveSize> boundary" $ do+      -- Setup+      persistedEvents <- liftIO $ generateFixedNumberOfEvents 5+      storeEventsRandomized persistedEvents+      -- Exercise+      (Just archiveId) <- archiveEvents 5+      -- Verify: Should not have any events in the <current> archive.+      currentArchiveEvents <- readArchive CurrentArchive+      verify $ length currentArchiveEvents `shouldBe` 0+      -- Verify archives+      verifyArchives 1 persistedEvents+      -- Verify contents of created archive+      archivedEvents <- readArchive (NamedArchive archiveId)+      verify $ archivedEvents `shouldHaveEventsEquivalentTo` persistedEvents++    it "'archiveEvents' should perform archival even if #unarchived events < archiveSize" $ do+      -- Setup+      persistedEvents <- liftIO $ generateFixedNumberOfEvents 7+      storeEventsRandomized persistedEvents+      -- Exercise+      (Just archiveId) <- archiveEvents 10+      -- Verify: Should not have any events in the <current> archive.+      currentArchiveEvents <- readArchive CurrentArchive+      verify $ length currentArchiveEvents `shouldBe` 0+      -- Verify archives+      verifyArchives 1 persistedEvents+      -- Verify contents of created archive+      archivedEvents <- readArchive (NamedArchive archiveId)+      verify $ archivedEvents `shouldHaveEventsEquivalentTo` persistedEvents++    it "'rotateArchives' should create as many archives as possible in a single invocation" $ do+      -- Setup+      persistedEvents <- liftIO $ generateFixedNumberOfEvents 17+      storeEventsRandomized persistedEvents+      -- Exercise+      rotateArchives 5+      -- Verify: Should not have any events in the <current> archive.+      currentArchiveEvents <- readArchive CurrentArchive+      verify $ length currentArchiveEvents `shouldBe` 2+      -- Verify archives+      verifyArchives 3 persistedEvents++  where+    -- Boilerplate avoidance+    it msg scope = Hspec.it msg $ runScope scope+    runScope = mkRunScope testKitSettings $ \a -> do+      -- Repository setup+      (archiveStore, eventStore) <- (tksMakeContext testKitSettings) a+      -- Build the ambient state.+      return $ Scope archiveStore eventStore++-- Publish a sequence of events.+publishEvents :: (NFData e, Show e) => UUID -> [PersistedEvent e] -> ScopeM (Scope e) ()+publishEvents aggregateId pes = do+  eventStore <- fmap scopeEventStore ask+  liftIO $ do+    batches <- doChunk pes  -- Chunk list of events into randomly sized batches.+    forM_ batches $ \batch -> do+      chunks <- doChunk batch    -- Re-chunk each batch into (possibly) multiple command invokations.+      forM_ chunks $ \chunk -> do+        (esStoreEvents eventStore) aggregateId chunk+  where+    doChunk xs = do+      n <- liftIO $ R.getStdRandom $ R.randomR (0, (length xs - 1) `div` 2)+      liftIO $ chunkRandomly n xs++-- Generate and publish a series of events to an aggregate.+genEvents :: UUID -> Int -> Int -> ScopeM (Scope ByteString) [(UUID, PersistedEvent ByteString)]+genEvents aggregateId n i0 = do+  pes <- liftIO $ genEvents'+  publishEvents aggregateId pes+  return $ map (\pe -> (aggregateId, pe)) pes+  where+    genEvents' :: IO [PersistedEvent ByteString]+    genEvents' = do+      es <- replicateM n $ randomByteString 8+      pes <- forM (zip [0..] es) $ \(i, e) -> do+               eventId <- R.randomIO+               return $ PersistedEvent e (i0 + i) eventId+      return pes
+ src/Data/CQRS/Test/Internal/ArchiveStoreUtils.hs view
@@ -0,0 +1,68 @@+module Data.CQRS.Test.Internal.ArchiveStoreUtils+    ( readAllEventsFromArchiveStore+    ) where++import           Control.Monad.IO.Class (liftIO)+import           Data.IORef (newIORef, atomicModifyIORef', readIORef)+import           Data.CQRS.Types.ArchiveMetadata (ArchiveMetadata(..))+import           Data.CQRS.Types.ArchiveRef (ArchiveRef(..))+import           Data.CQRS.Types.ArchiveStore (ArchiveStore(..), enumerateAllEvents)+import           Data.CQRS.Types.PersistedEvent (PersistedEvent)+import           Data.CQRS.Test.Internal.Scope (ScopeM, ask)+import           Data.UUID.Types (UUID)+import qualified System.IO.Streams.List as SL+import           Test.Hspec (shouldBe)++-- Read all events from the event store, using the archives. Also+-- asserts that all archives have consistent metadata and returns the+-- number of archives.+readAllEventsFromArchiveStore :: (s -> ArchiveStore e) -> ScopeM s (Int, [(UUID, PersistedEvent e)])+readAllEventsFromArchiveStore f = do+  archiveStore <- fmap f ask+  archiveCount <- liftIO $ assertConsistentArchiveMetadata archiveStore+  events <- liftIO $ readAllEvents' archiveStore+  return (archiveCount, events)++-- Retrieve all events from an event store.+readAllEvents' :: ArchiveStore e -> IO [(UUID, PersistedEvent e)]+readAllEvents' archiveStore = do+  eventsRef <- newIORef [ ]+  enumerateAllEvents archiveStore $ \inputStream -> do+    events <- SL.toList inputStream+    atomicModifyIORef' eventsRef (\events' -> (events' ++ events, ()))+  readIORef eventsRef++-- Assert that all archives have consistent metadata and return the+-- number of archives that were traversed (not counting the "Current"+-- archive).+assertConsistentArchiveMetadata :: ArchiveStore e -> IO Int+assertConsistentArchiveMetadata archiveStore = do+  -- We have a special case for "no archives".+  maybeLatestArchiveMetadata <- asReadLatestArchiveMetadata archiveStore+  case maybeLatestArchiveMetadata of+    Nothing ->+      return 0  -- There's only the "current" archive, and so there's nothing to verify.+    Just archiveMetadata ->+      walk CurrentArchive archiveMetadata 0++  where+    walk previousArchiveRef archiveMetadata count = do+      -- Make sure the nextArchiveId reference fits with the previous (recursion-wise) archive.+      previousArchiveRef `shouldBe` amNextArchiveId archiveMetadata+      -- Load up the previous archive in the chain.+      case amPreviousArchiveId archiveMetadata of+        Nothing -> do+          return $ count + 1 -- Reached the first archive.+        Just previousArchiveId -> do+          -- Load up metadata for previous archive.+          maybePreviousArchiveMetadata <- (asReadArchiveMetadata archiveStore) previousArchiveId+          case maybePreviousArchiveMetadata of+            Nothing ->+              error "No metadata for previous archive?"+            Just previousArchiveMetadata -> do+              -- Archive ID of the current archive+              let archiveRef = NamedArchive $ amArchiveId archiveMetadata+              -- Make sure we the next link of the previous archive point to "us".+              archiveRef `shouldBe` (amNextArchiveId previousArchiveMetadata)+              -- Check the remainder of the chain of archives.+              walk archiveRef previousArchiveMetadata $ count + 1
+ src/Data/CQRS/Test/Internal/EventStoreTest.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+module Data.CQRS.Test.Internal.EventStoreTest+    ( mkEventStoreSpec+    ) where++import           Control.Exception.Lifted (try)+import           Control.Monad.IO.Class (liftIO)+import           Data.ByteString (ByteString)+import           Data.CQRS.Test.Internal.TestKitSettings+import           Data.CQRS.Test.Internal.Scope (ScopeM, verify, ask, randomUUID)+import qualified Data.CQRS.Test.Internal.Scope as S+import           Data.CQRS.Types.EventStore (EventStore, StoreError(VersionConflict))+import qualified Data.CQRS.Types.EventStore as ES+import           Data.CQRS.Types.PersistedEvent+import           Data.UUID.Types (UUID)+import           Test.Hspec (Spec, describe, shouldBe)+import qualified Test.Hspec as Hspec+import qualified System.IO.Streams.List as SL++-- Ambient data for test scope for each spec.+data Scope e = Scope { scopeEventStore :: EventStore e+                     }++-- Store given events in exactly the order given.+storeEvents :: UUID -> [PersistedEvent e] -> ScopeM (Scope e) ()+storeEvents aggregateId events = do+  eventStore <- fmap scopeEventStore ask+  liftIO $ (ES.esStoreEvents eventStore) aggregateId events++-- Read all events for a given aggregate.+readEvents :: UUID -> ScopeM (Scope e) [PersistedEvent e]+readEvents aggregateId = do+  eventStore <- fmap scopeEventStore ask+  liftIO $ ES.esRetrieveEvents eventStore aggregateId (-1) $ SL.toList++-- Test suite for event store which stores 'ByteString' events.+mkEventStoreSpec :: TestKitSettings a (EventStore ByteString) -> Spec+mkEventStoreSpec testKitSettings = do++  describe "EventStore implementation" $ do++    it "should be able to retrieve stored events" $ do+      aggregateId <- randomUUID+      eventId0 <- randomUUID+      eventId1 <- randomUUID+      -- Write two events.+      let expectedEvents = [ PersistedEvent "test event 0" 0 eventId0+                           , PersistedEvent "test event 1" 1 eventId1+                           ]+      storeEvents aggregateId expectedEvents+      -- Retrieve the stored events.+      actualEvents <- readEvents aggregateId+      -- Assert that we've retrieved the expected events in order.+      verify $ actualEvents `shouldBe` expectedEvents++    it "should throw a VersionConflict exception when storing conflicting events in a single operation" $ do+      aggregateId <- randomUUID+      eventId0 <- randomUUID+      eventId1 <- randomUUID+      -- Write two conflicting events.+      let conflictingEvents = [ PersistedEvent "test event 0" 0 eventId0+                              , PersistedEvent "test event 1" 0 eventId1+                              ]+      storeEvents aggregateId conflictingEvents `shouldThrow` VersionConflict aggregateId+      -- Make sure we didn't actually store any events+      storedEvents <- readEvents aggregateId+      verify $ length storedEvents `shouldBe` 0++    it "should throw a VersionConflict exception when storing conflicting events in multiple operations" $ do+      aggregateId <- randomUUID+      eventId0 <- randomUUID+      eventId1 <- randomUUID+      -- Write a single event+      let initialEvent = PersistedEvent "test event 0" 0 eventId0+      storeEvents aggregateId [initialEvent]+      -- Write the event that should conflict+      let conflictingEvents = [ PersistedEvent "test event 1" 0 eventId1 ]+      storeEvents aggregateId conflictingEvents `shouldThrow` VersionConflict aggregateId+      -- Make sure we didn't write the second event+      storedEvents <- readEvents aggregateId+      verify $ length storedEvents `shouldBe` 1+      verify $ (storedEvents !! 0) `shouldBe` initialEvent++  where+    runScope = S.mkRunScope testKitSettings $ \a -> do+                                     eventStore <- tksMakeContext testKitSettings a+                                     return $ Scope eventStore+    -- Shorthands+    it msg scope = Hspec.it msg $ runScope scope++    shouldThrow action exc = do+      resultOrExc <- try $ action+      liftIO $ resultOrExc `shouldBe` (Left exc)
+ src/Data/CQRS/Test/Internal/RepositoryTest.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CQRS.Test.Internal.RepositoryTest+    ( mkRepositorySpec+    ) where++import           Control.DeepSeq (NFData)+import           Control.Monad (forM_, liftM)+import           Control.Monad.Trans.Reader (ask)+import           Control.Monad.IO.Class (liftIO)+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString as B+import           Data.CQRS.Command (CommandT)+import qualified Data.CQRS.Command as C+import           Data.CQRS.Query+import           Data.CQRS.Repository+import           Data.CQRS.Types.EventStore (EventStore)+import           Data.CQRS.Types.SnapshotStore (nullSnapshotStore, SnapshotStore)+import           Data.CQRS.Test.Internal.AggregateAction (byteStringAggregateAction)+import           Data.CQRS.Test.Internal.Scope (ScopeM, verify, randomUUID, mkRunScope)+import           Data.CQRS.Test.Internal.TestKitSettings+import           Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')+import           Data.Maybe (fromJust)+import           Data.UUID.Types (UUID)+import qualified System.Random as R+import qualified Test.Hspec as Hspec+import           Test.Hspec (Spec, shouldBe)+import           Test.HUnit (assertBool)++-- Ambient data for test scope for each spec.+data Scope a e = Scope { scopeRepository :: Repository a e+                       , scopePublishedEvents :: IORef [(UUID, e, Int)]+                       }++-- Assert that the given list of events was published.+assertDidPublish :: (Show e, Eq e) => [(UUID, e, Int)] -> ScopeM (Scope a e) ()+assertDidPublish expectedEvents = do+  publishedEventsRef <- fmap scopePublishedEvents $ ask+  verify $ do+    publishedEvents <- readIORef publishedEventsRef+    length publishedEvents `shouldBe` length expectedEvents+    forM_ (zip publishedEvents expectedEvents) $ uncurry shouldBe++-- Get the repository which is in scope.+getRepository :: ScopeM (Scope a e) (Repository a e)+getRepository = fmap scopeRepository ask++-- Run a command in scope.+runCommandT :: CommandT a e IO r -> ScopeM (Scope a e) r+runCommandT command = do+  repository <- getRepository+  liftIO $ C.runCommandT repository command++-- Create a new test scope runner from the test kit settings.+mkRunScope' :: Int -> TestKitSettings s (EventStore ByteString, SnapshotStore ByteString) -> (ScopeM (Scope ByteString ByteString) r -> IO r)+mkRunScope' snapshotFrequency testKitSettings = mkRunScope testKitSettings $ \a -> do+  -- We collect all events published by the repository for verification+  publishedEventsRef <- newIORef []+  let publish (aggregateId, events') = atomicModifyIORef' publishedEventsRef $ \events ->+        (events ++ map (\(PersistedEvent e s _) -> (aggregateId, e, s)) events', ())+  -- Repository setup+  (eventStore, snapshotStore) <- (tksMakeContext testKitSettings) a+  let settings = setSnapshotFrequency snapshotFrequency $ defaultSettings+  let repository = newRepository settings byteStringAggregateAction eventStore snapshotStore publish R.randomIO+  -- Build the ambient state.+  return $ Scope repository publishedEventsRef++-- Given test kit settings, create the full spec for testing the+-- repository implementation against those settings.+mkRepositorySpec :: TestKitSettings a (EventStore ByteString, SnapshotStore ByteString) -> Spec+mkRepositorySpec testKitSettings = do+  -- We do each set of tests both *with* and *without* a snapshot+  -- store and with varying snapshot frequency. This should hopefully+  -- give us enough coverage against the handling of snapshots in the+  -- Repository portion of the code.+  forM_ [ 3, 5 ] $ \f -> do+    let fs = "frequency " ++ show f+    let s1 = "(snapshots; " ++ fs ++ ")"+    let s2 = "(null snapshots; " ++ fs ++ ")"+    mkSpec s1 (mkRunScope' f $ testKitSettings)+    mkSpec s2 (mkRunScope' f $ disableSnapshots testKitSettings)+  where+    disableSnapshots settings =+        settings { tksMakeContext = \a -> do+                        (eventStore, _) <- tksMakeContext settings a+                        return (eventStore, nullSnapshotStore)+                 }++mkSpec :: String -> (ScopeM (Scope ByteString ByteString) () -> IO ()) -> Spec+mkSpec suffix runScope = do++  describe "Repository" $ do++    it "should support creating an aggregate and returning its value" $ do+      -- Exercise+      (aggregateId, a) <- newAggregate ["3"]+      -- Should have updated aggregate value+      verify $ a `shouldBe` "3"+      -- Should have published appropriate event+      assertDidPublish [ (aggregateId, "3", 0) ]++    it "should support creating an aggregate and loading it" $ do+      -- Exercise+      (aggregateId, _) <- newAggregate ["4"]+      -- Should have an updated aggregate value+      a <- loadAggregate aggregateId+      verify $ a `shouldBe` "4"+      -- Should have published appropriate event+      assertDidPublish [ (aggregateId, "4", 0) ]++    it "should support publishing >1 events to an aggregate (1 txn)" $ do+      -- Exercise+      (aggregateId, _) <- newAggregate ["7", "1"]+      -- Should have an updated aggregate value+      a <- loadAggregate aggregateId+      verify $ a `shouldBe` "71"+      -- Should have published two events+      assertDidPublish [ (aggregateId, "7", 0)+                       , (aggregateId, "1", 1)+                       ]++    it "should support publishing >1 events to an aggregate (2 txns)" $ do+      -- Exercise: 1st transaction+      (aggregateId, _) <- newAggregate ["9"]+      -- Exercise: 2nd transaction+      _ <- runCommandT $ do+        C.updateAggregate aggregateId $ \_ -> do+          C.publishEvent $ "7"+      -- Should have an updated aggregate value.+      a <- loadAggregate aggregateId+      verify $ a `shouldBe` "97"+      -- Should have published two events.+      assertDidPublish [ (aggregateId, "9", 0)+                       , (aggregateId, "7", 1)+                       ]++    it "should support publishing a large number of events to an aggregate" $ do+      -- Setup+      let events = map B8.pack $ map show ([1.. 100] :: [Int])+      -- Exercise+      (aggregateId, _) <- newAggregate events+      -- Verify+      a <- loadAggregate aggregateId+      verify $ a `shouldBe` B.concat events++    it "should be possible to find an existing aggregate" $ do+      -- Setup+      (aggregateId, _) <- newAggregate ["xyzzy"]+      -- Exercise+      a <- findAggregate aggregateId+      -- Should have found it+      verify $ a `shouldBe` Just "xyzzy"++    it "should not be possible to find a non-existent aggregate" $ do+      -- Exercise+      aggregateId <- randomUUID+      a <- findAggregate aggregateId+      -- Should NOT have found anything+      verify $ a `shouldBe` Nothing++    it "should be possible to work with two different aggregates (serially) in a command" $ do+      -- Setup+      aggregateId0 <- randomUUID+      aggregateId1 <- randomUUID+      -- Exercise+      _ <- runCommandT $ do+        C.createAggregate aggregateId0 $ \_ -> do+          C.publishEvent "34"+        C.createAggregate aggregateId1 $ \_ -> do+          C.publishEvent "1"+        C.updateAggregate aggregateId0 $ \_ -> do+          C.publishEvent "5"+      -- Should have updated values for both aggregates+      a0 <- loadAggregate aggregateId0+      a1 <- loadAggregate aggregateId1+      verify $ a0 `shouldBe` "345"+      verify $ a1 `shouldBe` "1"+      -- Should have published events in order of publishing+      assertDidPublish [ (aggregateId0, "34", 0)+                       , (aggregateId1,  "1", 0)+                       , (aggregateId0,  "5", 1)+                       ]++    it "'getter' function returns up-to-date values when updating an aggregate" $ do+      -- Setup+      (aggregateId, _) <- newAggregate ["x"]+      -- Exercise:+      Just (a, a') <- runCommandT $ do -- We'll assume pattern match will work, otherwise test fails+        C.updateAggregate aggregateId $ \get -> do+          a <- get+          C.publishEvent "y"+          a' <- get+          return (a, a')+      -- Should have received original value in a'+      verify $ a `shouldBe` "x"+      -- Should have received an updated value in a''+      verify $ a' `shouldBe` "xy"+      -- Should have published events+      assertDidPublish [ (aggregateId, "x", 0)+                       , (aggregateId, "y", 1)+                       ]++    it "'getter' function returns up-to-date values when creating an aggregate" $ do+      -- Setup+      aggregateId <- randomUUID+      -- Exercise+      (a, a') <- runCommandT $ do+        C.createAggregate aggregateId $ \get -> do+          a <- get  -- Should return Nothing+          C.publishEvent "x"+          a' <- get  -- Should reutrn (Just "x")+          return (a, a')+      -- Should have received Nothing in a' since aggregate didn't actually exist+      verify $ a `shouldBe` Nothing+      -- Should have received (Just "x") in a'' since we'd just published an "x" event+      verify $ a' `shouldBe` (Just "x")+      -- Should have published event+      assertDidPublish [ (aggregateId, "x", 0) ]++  where+    -- Boilerplate avoidance+    it msg scope = Hspec.it msg $ runScope scope+    describe msg = Hspec.describe (msg ++ " " ++ suffix)++-- Create an aggregate with an initial series of events.+newAggregate :: (NFData a, NFData e) => [e] -> ScopeM (Scope a e) (UUID, a)+newAggregate es = do+  -- Create new aggregate ID.+  aggregateId <- randomUUID+  -- Sanity check+  liftIO $ assertBool "List of initial events must be non-emtpy" (length es > 0)+  -- Create the aggregate with its initial list of events+  runCommandT $ do+    a <- C.createAggregate aggregateId $ \getAggregate -> do+      forM_ es $ C.publishEvent+      liftM fromJust $ getAggregate+    return (aggregateId, a)++-- Load an aggregate value.+loadAggregate :: UUID -> ScopeM (Scope a e) a+loadAggregate aggregateId = liftM get $ runCommandT $ C.readAggregate aggregateId+    where+      get Nothing  = error $ "loadAggregate: Missing expected aggregate"+      get (Just a) = a++-- Get aggregate's value, if the aggregate exists+findAggregate :: UUID -> ScopeM (Scope a e) (Maybe a)+findAggregate = do+  runCommandT . (flip C.updateAggregate) id
+ src/Data/CQRS/Test/Internal/Scope.hs view
@@ -0,0 +1,36 @@+module Data.CQRS.Test.Internal.Scope+    ( ScopeM+    , ask+    , mkRunScope+    , randomUUID+    , verify+    ) where++import           Control.Exception (bracket)+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import           Data.CQRS.Test.Internal.TestKitSettings+import           Data.UUID.Types (UUID)+import           System.Random (randomIO)++-- Monad providing ambient access to the current spec scope. This is+-- test code, so we don't bother making it opaque.+type ScopeM s r = ReaderT s IO r++-- Verify a property in the current spec scope. This is just an alias+-- for 'lifIO' which can be used to aid readability.+verify :: IO r -> ScopeM s r+verify = liftIO++-- Lifted version of randomUUID. This is just an alias for convenience.+randomUUID :: ScopeM s UUID+randomUUID = liftIO $ randomIO++-- Make a "scope runner" function from a given IO action and test+-- settings. Each scope will be automatically bracketed by the "setUp"+-- and "tearDown" functions of of the test settings.+mkRunScope :: TestKitSettings a ctx -> (a -> IO s) -> (ScopeM s r -> IO r)+mkRunScope testKitSettings mkScope  = \action -> do+  bracket (tksSetUp testKitSettings)+          (tksTearDown testKitSettings) $ \a -> do+    mkScope a >>= runReaderT action
+ src/Data/CQRS/Test/Internal/SnapshotTest.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+module Data.CQRS.Test.Internal.SnapshotTest+    ( mkSnapshotStoreSpec+    ) where++import           Control.Monad.IO.Class (liftIO)+import           Data.ByteString (ByteString)+import           Data.CQRS.Test.Internal.Scope (ScopeM, verify, ask, randomUUID)+import qualified Data.CQRS.Test.Internal.Scope as S+import           Data.CQRS.Test.Internal.TestKitSettings+import           Data.CQRS.Types.Snapshot+import           Data.CQRS.Types.SnapshotStore+import           Data.UUID.Types (UUID)+import           Test.Hspec (Spec, describe, shouldBe)+import qualified Test.Hspec as Hspec++-- Write snapshot+writeSnapshot :: UUID -> Snapshot a -> ScopeM (SnapshotStore a) ()+writeSnapshot aggregateId snapshot = do+  snapshotStore <- ask+  liftIO $ ssWriteSnapshot snapshotStore aggregateId snapshot++-- Read a snapshot+readSnapshot :: UUID -> ScopeM (SnapshotStore a) (Maybe (Snapshot a))+readSnapshot aggregateId = do+  snapshotStore <- ask+  liftIO $ ssReadSnapshot snapshotStore aggregateId++-- Test suite for memory backend.+mkSnapshotStoreSpec :: TestKitSettings a (SnapshotStore ByteString) -> Spec+mkSnapshotStoreSpec testKitSettings = do++  describe "SnapshotStore" $ do++    it "writing first snapshot works" $ do+      aggregateId <- randomUUID+      -- Write the snapshot.+      let rs = (Snapshot 3 "Hello, world")+      writeSnapshot aggregateId rs+      -- Read the snapshot.+      rs' <- readSnapshot aggregateId+      -- Assert that we've retrieved the right snapshot.+      verify $ rs' `shouldBe` Just rs++    it "updating snapshot overwrites existing one" $ do+      aggregateId <- randomUUID+      -- Write snapshot "twice"+      let rs1 = (Snapshot 3 "Hello")+      let rs2 = (Snapshot 4 "Goodbye")+      writeSnapshot aggregateId rs1+      writeSnapshot aggregateId rs2+      -- Read latest snapshot+      rs' <- readSnapshot aggregateId+      -- Assert that the latter snapshot was retrieved+      verify $ rs' `shouldBe` Just rs2++  where+    runScope = S.mkRunScope testKitSettings (tksMakeContext testKitSettings)+    it msg = Hspec.it msg . runScope
+ src/Data/CQRS/Test/Internal/TestKitSettings.hs view
@@ -0,0 +1,22 @@+module Data.CQRS.Test.Internal.TestKitSettings+    ( TestKitSettings(..)+    , mkBracket+    ) where++import Control.Exception.Base (bracket)++-- | Test kit settings with a test context of type 'ctx'.+data TestKitSettings a ctx = TestKitSettings+    { tksSetUp :: IO a+    , tksTearDown :: a -> IO ()+    , tksMakeContext :: a -> IO ctx+    }++-- | Create a "bracket" for a computation which ensures that+-- the setUp and tearDown phases happen no matter what else+-- happens during the computation.+mkBracket :: TestKitSettings a ctx -> (a -> IO b) -> IO b+mkBracket testKitSettings action =+    bracket (tksSetUp testKitSettings)+            (tksTearDown testKitSettings)+            action
+ src/Data/CQRS/Test/Internal/Utils.hs view
@@ -0,0 +1,44 @@+module Data.CQRS.Test.Internal.Utils+    ( chunkRandomly+    , chunkSized+    , chooseRandom+    , randomByteString+    ) where++import           Control.Monad.IO.Class (liftIO)+import           Control.Monad (replicateM)+import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import           Data.List (sort)+import           System.Random (randomR, randomRIO, getStdRandom, random)++-- Chunk a list randomly into 'n' chunks. Order of the elements is+-- preserved.+chunkRandomly :: Int -> [a] -> IO [[a]]+chunkRandomly n xs = do+    let lengthXs = length xs+    splitIndices <- fmap sort $ replicateM (n - 1) $ getStdRandom $ randomR (0, lengthXs - 1)+    return $ map chunk $ pairs $ [0] ++ splitIndices ++ [lengthXs]+  where+    pairs is = zip is (tail is)+    chunk (i, j) = take (j - i) $ drop i xs++-- Chunk a list into pieces of given average size (uniformly+-- distributed).+chunkSized :: Int -> [a] -> IO [[a]]+chunkSized avgSize xs = do+  n <- liftIO $ getStdRandom $ randomR (0, (length xs - 1) `div` avgSize)+  liftIO $ chunkRandomly n xs++-- Generate a random byte string of the given length.+randomByteString :: Int -> IO ByteString+randomByteString n = do+  -- Let's just generate 8 byte of random contents for each event.+  w8 <- replicateM n $ getStdRandom random+  return $ B.pack w8++-- Choose a random element from list.+chooseRandom :: [a] -> IO a+chooseRandom xs = do+  i <- randomRIO (0, length xs - 1)+  return $ xs !! i
+ src/Data/CQRS/Test/TestKit.hs view
@@ -0,0 +1,13 @@+module Data.CQRS.Test.TestKit+    ( TestKitSettings(..)+    , mkEventStoreSpec+    , mkRepositorySpec+    , mkSnapshotStoreSpec+    , mkArchiveStoreSpec+    ) where++import Data.CQRS.Test.Internal.ArchiveStoreTest (mkArchiveStoreSpec)+import Data.CQRS.Test.Internal.EventStoreTest (mkEventStoreSpec)+import Data.CQRS.Test.Internal.RepositoryTest (mkRepositorySpec)+import Data.CQRS.Test.Internal.SnapshotTest (mkSnapshotStoreSpec)+import Data.CQRS.Test.Internal.TestKitSettings (TestKitSettings(..))