├── .ghci ├── .gitignore ├── .gitmodules ├── .project-settings.yml ├── .stylish-haskell.yaml ├── .travis.yml ├── Dockerfile ├── LICENSE ├── README.md ├── dynamodb-eventstore-client ├── LICENSE ├── Setup.hs ├── client │ └── Main.hs └── dynamodb-eventstore-client.cabal ├── dynamodb-eventstore-web ├── LICENSE ├── Setup.hs ├── dynamodb-eventstore-web.cabal ├── src │ └── DynamoDbEventStore │ │ ├── EventStoreActions.hs │ │ ├── Feed.hs │ │ ├── GlobalPaging.hs │ │ ├── Paging.hs │ │ └── Webserver.hs ├── tests │ ├── DynamoDbEventStore │ │ ├── FeedOutputSpec.hs │ │ ├── GlobalPagingSpec.hs │ │ └── PagingSpec.hs │ ├── WebserverInternalSpec.hs │ ├── WebserverSpec.hs │ └── tastytests.hs └── web │ └── Main.hs ├── dynamodb-eventstore ├── LICENSE ├── Setup.hs ├── dynamodb-eventstore.cabal ├── src │ ├── DynamoDbEventStore.hs │ └── DynamoDbEventStore │ │ ├── AmazonkaImplementation.hs │ │ ├── Constants.hs │ │ ├── EventStoreCommands.hs │ │ ├── GlobalFeedWriter.hs │ │ ├── ProjectPrelude.hs │ │ ├── Storage │ │ ├── GlobalStreamItem.hs │ │ ├── HeadItem.hs │ │ └── StreamItem.hs │ │ ├── Streams.hs │ │ └── Types.hs └── tests │ ├── DynamoCmdAmazonkaTests.hs │ ├── DynamoDbEventStore │ ├── DynamoCmdInterpreter.hs │ ├── GlobalFeedWriterSpec.hs │ ├── InMemoryCache.hs │ └── InMemoryDynamoTable.hs │ └── tastytests.hs ├── example-commands.txt ├── scripts └── run-dynamodb-local.sh └── stack.yaml /.ghci: -------------------------------------------------------------------------------- 1 | :set -XOverloadedStrings 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | cabal.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *~ 19 | *.db 20 | scripts/dynamodb_local_latest/ 21 | halcyon-env 22 | TAGS 23 | tags 24 | .stack-work/ 25 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "libraries/aws"] 2 | path = libraries/aws 3 | url = https://github.com/adbrowne/aws.git 4 | -------------------------------------------------------------------------------- /.project-settings.yml: -------------------------------------------------------------------------------- 1 | binary-ghc-args: 2 | - -O 3 | - -threaded 4 | module-template: ! 'module MODULE_NAME where 5 | 6 | ' 7 | extensions: {} 8 | environment: ghc-7.8-unstable 9 | auto-hidden: [] 10 | cabal-file: project.cabal 11 | version: 1 12 | extra-packages: ! 'hackage: hspec-core 2.1.4 13 | 14 | hackage: hspec-discover 2.1.4 15 | 16 | hackage: hspec 2.1.4 17 | 18 | hackage: tasty-hspec 1.1 19 | 20 | ' 21 | ghc-args: 22 | - -Wall 23 | excluded-modules: 24 | - Setup.hs 25 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Import cleanup 19 | - imports: 20 | # There are different ways we can align names and lists. 21 | # 22 | # - global: Align the import names and import list throughout the entire 23 | # file. 24 | # 25 | # - file: Like global, but don't add padding when there are no qualified 26 | # imports in the file. 27 | # 28 | # - group: Only align the imports per group (a group is formed by adjacent 29 | # import lines). 30 | # 31 | # - none: Do not perform any alignment. 32 | # 33 | # Default: global. 34 | align: global 35 | 36 | # Folowing options affect only import list alignment. 37 | #stylish-haskell 38 | # - after_alias: Import list is aligned with end of import including 39 | # 'as' and 'hiding' keywords. 40 | # 41 | # > import qualified Data.List as List (concat, foldl, foldr, head, 42 | # > init, last, length) 43 | # 44 | # - with_alias: Import list is aligned with start of alias or hiding. 45 | # 46 | # > import qualified Data.List as List (concat, foldl, foldr, head, 47 | # > init, last, length) 48 | # 49 | # - new_line: Import list starts always on new line. 50 | # 51 | # > import qualified Data.List as List 52 | # > (concat, foldl, foldr, head, init, last, length) 53 | # 54 | # Default: after alias 55 | list_align: after_alias 56 | 57 | # Long list align style takes effect when import is too long. This is 58 | # determined by 'columns' setting. 59 | # 60 | # - inline: This option will put as much specs on same line as possible. 61 | # 62 | # - new_line: Import list will start on new line. 63 | # 64 | # - new_line_multiline: Import list will start on new line when it's 65 | # short enough to fit to single line. Otherwise it'll be multiline. 66 | # 67 | # - multiline: One line per import list entry. 68 | # Type with contructor list acts like single import. 69 | # 70 | # > import qualified Data.Map as M 71 | # > ( empty 72 | # > , singleton 73 | # > , ... 74 | # > , delete 75 | # > ) 76 | # 77 | # Default: inline 78 | long_list_align: inline 79 | 80 | # List padding determines indentation of import list on lines after import. 81 | # This option affects 'list_align' and 'long_list_align'. 82 | list_padding: 4 83 | 84 | # Separate lists option affects formating of import list for type 85 | # or class. The only difference is single space between type and list 86 | # of constructors, selectors and class functions. 87 | # 88 | # - true: There is single space between Foldable type and list of it's 89 | # functions. 90 | # 91 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 92 | # 93 | # - false: There is no space between Foldable type and list of it's 94 | # functions. 95 | # 96 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 97 | # 98 | # Default: true 99 | separate_lists: true 100 | 101 | # Language pragmas 102 | - language_pragmas: 103 | # We can generate different styles of language pragma lists. 104 | # 105 | # - vertical: Vertical-spaced language pragmas, one per line. 106 | # 107 | # - compact: A more compact style. 108 | # 109 | # - compact_line: Similar to compact, but wrap each line with 110 | # `{-#LANGUAGE #-}'. 111 | # 112 | # Default: vertical. 113 | style: vertical 114 | 115 | # Align affects alignment of closing pragma brackets. 116 | # 117 | # - true: Brackets are aligned in same collumn. 118 | # 119 | # - false: Brackets are not aligned together. There is only one space 120 | # between actual import and closing bracket. 121 | # 122 | # Default: true 123 | align: true 124 | 125 | # stylish-haskell can detect redundancy of some language pragmas. If this 126 | # is set to true, it will remove those redundant pragmas. Default: true. 127 | remove_redundant: true 128 | 129 | # Align the types in record declarations 130 | - records: {} 131 | 132 | # Replace tabs by spaces. This is disabled by default. 133 | # - tabs: 134 | # # Number of spaces to use for each tab. Default: 8, as specified by the 135 | # # Haskell report. 136 | # spaces: 8 137 | 138 | # Remove trailing whitespace 139 | - trailing_whitespace: {} 140 | 141 | # A common setting is the number of columns (parts of) code will be wrapped 142 | # to. Different steps take this into account. Default: 80. 143 | columns: 80 144 | 145 | # Sometimes, language extensions are specified in a cabal file or from the 146 | # command line instead of using language pragmas in the file. stylish-haskell 147 | # needs to be aware of these, so it can parse the file correctly. 148 | # 149 | # No language extensions are enabled by default. 150 | # language_extensions: 151 | # - TemplateHaskell 152 | # - QuasiQuotes 153 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: c 3 | env: 4 | matrix: 5 | - AWS_ACCESS_KEY_ID=foo AWS_SECRET_ACCESS_KEY=bar 6 | addons: 7 | apt: 8 | packages: 9 | - libgmp-dev 10 | before_install: 11 | - mkdir -p ~/.local/bin 12 | - export PATH=$HOME/.local/bin:$PATH 13 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards 14 | --strip-components=1 -C ~/.local/bin '*/stack' 15 | before_script: 16 | - "./scripts/run-dynamodb-local.sh &" 17 | script: 18 | - stack $ARGS --no-terminal --install-ghc test dynamodb-eventstore-web:test:tasty --pedantic 19 | - stack $ARGS --no-terminal --install-ghc test dynamodb-eventstore:test:tasty --pedantic --test-arguments "--quickcheck-max-size 2 --quickcheck-tests 10" 20 | before_deploy: 21 | - mkdir release 22 | - cp `stack path --dist-dir`/build/web/web release/ 23 | deploy: 24 | provider: releases 25 | api_key: 26 | secure: Wk2Z/jislfOnyJg9BlFtJCX2CDgjiTM2XtU9EcFCksEtXhVtYAY/IaQYXuyusRm/cXOE3x3FQQvcWH2uazQCpZAfWFETEA88g+CRT/N3H0YJcL7ciQdN6huAuqxOT/XA5Wkmj1kspNM2mknE1alzRysyrkfmnkP4j3JcC2cDE9g= 27 | file: "release/web" 28 | on: 29 | tags: true 30 | repo: adbrowne/dynamodb-eventstore 31 | cache: 32 | directories: 33 | - "$HOME/.stack" 34 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # DynamoDB EventStore (github.com/adbrowne/DynamoEventStore) 2 | # 3 | # VERSION 0.0.1 4 | 5 | FROM ubuntu:14.04 6 | MAINTAINER Andrew Browne 7 | 8 | RUN apt-get update && apt-get install -y curl libgmp10 && apt-get clean 9 | 10 | RUN mkdir /opt/dynamoEventStore && curl -L https://github.com/adbrowne/DynamoEventStore/releases/download/v0.0.4/web > /opt/dynamoEventStore/web && chmod +x /opt/dynamoEventStore/web 11 | 12 | EXPOSE 3000 13 | 14 | WORKDIR /opt/dynamoEventStore 15 | 16 | CMD ./web 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Andrew Browne 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # EventStore using AWS DynamoDB as a backing store 2 | 3 | [![Build Status](https://travis-ci.org/adbrowne/dynamodb-eventstore.svg)](https://travis-ci.org/adbrowne/dynamodb-eventstore) 4 | -------------------------------------------------------------------------------- /dynamodb-eventstore-client/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Andrew Browne 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /dynamodb-eventstore-client/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /dynamodb-eventstore-client/dynamodb-eventstore-client.cabal: -------------------------------------------------------------------------------- 1 | -- Initial DynamoEventStore.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: dynamodb-eventstore-client 5 | version: 0.1.0.0 6 | synopsis: EventStore implementation on top of AWS DynamoDB 7 | -- description: 8 | homepage: http://github.com/adbrowne/DynamoEventStore 9 | license: MIT 10 | license-file: LICENSE 11 | author: Andrew Browne 12 | maintainer: brownie@brownie.com.au 13 | -- copyright: 14 | category: Database 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=1.10 18 | 19 | executable client 20 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 21 | default-extensions: NoImplicitPrelude 22 | build-depends: base, 23 | basic-prelude, 24 | wreq, 25 | pipes, 26 | ekg, 27 | random >= 1.1, 28 | text >= 1.2, 29 | aeson >= 0.8, 30 | async, 31 | resourcet, 32 | stm, 33 | taggy, 34 | semigroups, 35 | time, 36 | taggy-lens, 37 | unordered-containers, 38 | optparse-applicative, 39 | turtle, 40 | attoparsec, 41 | lens-aeson, 42 | mtl, 43 | amazonka, 44 | amazonka-dynamodb, 45 | dynamodb-eventstore, 46 | containers, 47 | aeson, 48 | ekg-core, 49 | uuid, 50 | bytestring, 51 | system-filepath, 52 | lens, 53 | blaze-markup, 54 | directory, 55 | filepath, 56 | Diff, 57 | MissingH, 58 | safe 59 | default-language: Haskell2010 60 | hs-source-dirs: client 61 | main-is: Main.hs 62 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Andrew Browne 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/dynamodb-eventstore-web.cabal: -------------------------------------------------------------------------------- 1 | -- Initial DynamoEventStore.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: dynamodb-eventstore-web 5 | version: 0.1.0.0 6 | synopsis: EventStore implementation on top of AWS DynamoDB 7 | -- description: 8 | homepage: http://github.com/adbrowne/DynamoEventStore 9 | license: MIT 10 | license-file: LICENSE 11 | author: Andrew Browne 12 | maintainer: brownie@brownie.com.au 13 | -- copyright: 14 | category: Database 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=1.10 18 | 19 | library 20 | GHC-Options: -Wall 21 | exposed-modules: DynamoDbEventStore.Webserver, 22 | DynamoDbEventStore.Feed, 23 | DynamoDbEventStore.EventStoreActions, 24 | DynamoDbEventStore.Paging, 25 | DynamoDbEventStore.GlobalPaging 26 | default-extensions: NoImplicitPrelude 27 | build-depends: base 28 | , basic-prelude 29 | , scotty >= 0.9 30 | , attoparsec 31 | , vector >= 0.11 32 | , text >= 1.2 33 | , HTTP 34 | , blaze-markup 35 | , mtl 36 | , aeson 37 | , aeson-pretty 38 | , time 39 | , semigroups 40 | , uuid 41 | , http-types 42 | , pipes 43 | , QuickCheck 44 | , quickcheck-instances 45 | , safe 46 | , dynamodb-eventstore 47 | hs-source-dirs: src 48 | default-language: Haskell2010 49 | 50 | executable web 51 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 52 | default-extensions: NoImplicitPrelude 53 | build-depends: base, 54 | basic-prelude, 55 | scotty >= 0.9, 56 | text >= 1.2, 57 | async, 58 | dynamodb-eventstore, 59 | dynamodb-eventstore-web, 60 | amazonka >= 1.0, 61 | lens, 62 | stm, 63 | mtl, 64 | warp, 65 | network-simple, 66 | amazonka-core >= 1.0, 67 | amazonka-dynamodb >= 1.0, 68 | exceptions, 69 | monad-control, 70 | optparse-applicative, 71 | transformers >= 0.4, 72 | transformers-base, 73 | ekg, 74 | ekg-core 75 | default-language: Haskell2010 76 | hs-source-dirs: web 77 | main-is: Main.hs 78 | 79 | Test-Suite tasty 80 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 81 | default-extensions: NoImplicitPrelude 82 | other-modules: DynamoDbEventStore.FeedOutputSpec 83 | , DynamoDbEventStore.PagingSpec 84 | , DynamoDbEventStore.GlobalPagingSpec 85 | , WebserverInternalSpec 86 | , WebserverSpec 87 | type: exitcode-stdio-1.0 88 | main-is: tastytests.hs 89 | hs-source-dirs: tests 90 | build-depends: base, 91 | basic-prelude, 92 | tasty >= 0.10, 93 | tasty-hspec >= 1.0, 94 | tasty-hunit >= 0.9, 95 | tasty-quickcheck >= 0.8, 96 | text-show >= 2, 97 | pipes, 98 | QuickCheck, 99 | safe, 100 | lrucache, 101 | quickcheck-instances, 102 | dodgerblue, 103 | cereal, 104 | time, 105 | uuid, 106 | stm, 107 | either, 108 | random, 109 | containers >= 0.5, 110 | aeson, 111 | async, 112 | aeson-pretty, 113 | MonadRandom, 114 | semigroups, 115 | unordered-containers, 116 | hashable, 117 | amazonka-dynamodb, 118 | lens, 119 | http-types >= 0.8, 120 | mtl >= 2.1, 121 | transformers, 122 | transformers-base, 123 | monad-loops, 124 | blaze-markup, 125 | wai >= 3.0, 126 | wai-extra >= 3.0, 127 | scotty >= 0.9, 128 | free >= 4.10, 129 | bytestring >= 0.10, 130 | text >= 1.2, 131 | dynamodb-eventstore, 132 | dynamodb-eventstore-web, 133 | ekg-core 134 | 135 | default-language: Haskell2010 -------------------------------------------------------------------------------- /dynamodb-eventstore-web/src/DynamoDbEventStore/EventStoreActions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | module DynamoDbEventStore.EventStoreActions( 9 | ReadStreamRequest(..), 10 | ReadEventRequest(..), 11 | ReadAllRequest(..), 12 | PostEventRequest(..), 13 | EventType(..), 14 | EventTime(..), 15 | EventEntry(..), 16 | EventStoreAction(..), 17 | EventWriteResult(..), 18 | PostEventResult(..), 19 | ReadStreamResult(..), 20 | ReadAllResult(..), 21 | ReadEventResult(..), 22 | StreamResult(..), 23 | StreamOffset, 24 | GlobalStreamResult(..), 25 | GlobalStreamOffset, 26 | EventStartPosition(..), 27 | GlobalStartPosition(..), 28 | GlobalFeedPosition(..), 29 | postEventRequestProgram, 30 | getReadStreamRequestProgram, 31 | getReadEventRequestProgram, 32 | getReadAllRequestProgram) where 33 | 34 | import BasicPrelude 35 | import Data.List.NonEmpty (NonEmpty (..)) 36 | import DynamoDbEventStore 37 | import DynamoDbEventStore.GlobalPaging 38 | import DynamoDbEventStore.Paging 39 | import qualified Test.QuickCheck as QC 40 | import Test.QuickCheck.Instances () 41 | 42 | -- High level event store actions 43 | -- should map almost one to one with http interface 44 | data EventStoreAction = 45 | PostEvent PostEventRequest | 46 | ReadStream ReadStreamRequest | 47 | ReadEvent ReadEventRequest | 48 | ReadAll ReadAllRequest deriving (Show) 49 | 50 | newtype PostEventResult = PostEventResult (Either EventStoreError EventWriteResult) deriving Show 51 | newtype ReadStreamResult = ReadStreamResult (Either EventStoreError (Maybe StreamResult)) deriving Show 52 | newtype ReadAllResult = ReadAllResult (Either EventStoreError GlobalStreamResult) deriving Show 53 | newtype ReadEventResult = ReadEventResult (Either EventStoreError (Maybe RecordedEvent)) deriving Show 54 | 55 | data PostEventRequest = PostEventRequest { 56 | perStreamId :: Text, 57 | perExpectedVersion :: Maybe Int64, 58 | perEvents :: NonEmpty EventEntry 59 | } deriving (Show) 60 | 61 | instance QC.Arbitrary PostEventRequest where 62 | arbitrary = PostEventRequest <$> (fromString <$> QC.arbitrary) 63 | <*> QC.arbitrary 64 | <*> ((:|) <$> QC.arbitrary <*> QC.arbitrary) 65 | 66 | data ReadEventRequest = ReadEventRequest { 67 | rerStreamId :: Text, 68 | rerEventNumber :: Int64 69 | } deriving (Show) 70 | 71 | postEventRequestProgram :: PostEventRequest -> EventStore EventWriteResult 72 | postEventRequestProgram (PostEventRequest sId ev eventEntries) = 73 | writeEvent (StreamId sId) ev eventEntries 74 | 75 | getReadEventRequestProgram :: ReadEventRequest -> EventStore (Maybe RecordedEvent) 76 | getReadEventRequestProgram (ReadEventRequest sId eventNumber) = 77 | readEvent (StreamId sId) eventNumber 78 | 79 | getReadStreamRequestProgram :: ReadStreamRequest -> EventStore (Maybe StreamResult) 80 | getReadStreamRequestProgram = 81 | runStreamRequest streamEventsProducer 82 | 83 | getReadAllRequestProgram :: ReadAllRequest -> EventStore GlobalStreamResult 84 | getReadAllRequestProgram = 85 | runGlobalStreamRequest globalEventsProducer globalEventKeysProducer 86 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/src/DynamoDbEventStore/Feed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module DynamoDbEventStore.Feed ( 7 | xmlFeed, 8 | jsonFeed, 9 | jsonEntry, 10 | Feed(..), 11 | recordedEventToFeedEntry, 12 | streamResultsToFeed, 13 | globalStreamResultsToFeed, 14 | globalFeedPositionToText) where 15 | 16 | import BasicPrelude 17 | import Data.Aeson 18 | import qualified Data.Attoparsec.ByteString as APBS 19 | import qualified Data.Text as T 20 | import Data.Time.Clock 21 | import Data.Time.Format 22 | import qualified Data.UUID 23 | import qualified Data.Vector as V 24 | import DynamoDbEventStore.EventStoreActions 25 | import DynamoDbEventStore.Paging 26 | import DynamoDbEventStore.EventStoreCommands 27 | import DynamoDbEventStore.Types 28 | import Network.HTTP.Base 29 | import Text.Blaze 30 | import Text.Blaze.Internal (customLeaf, 31 | customParent) 32 | 33 | data Feed 34 | = Feed 35 | { feedId :: Text 36 | , feedTitle :: Text 37 | , feedUpdated :: UTCTime 38 | , feedSelfUrl :: Text 39 | , feedStreamId :: Text 40 | , feedAuthor :: Author 41 | , feedLinks :: [Link] 42 | , feedEntries :: [Entry] 43 | } 44 | deriving (Show) 45 | 46 | data Author 47 | = Author 48 | { authorName :: Text 49 | } 50 | deriving (Show) 51 | 52 | data Entry 53 | = Entry 54 | { entryId :: Text 55 | , entryTitle :: Text 56 | , entryUpdated :: UTCTime 57 | , entryContent :: EntryContent 58 | , entryLinks :: [Link] 59 | , entrySummary :: Text 60 | } 61 | deriving (Show) 62 | 63 | data EntryContent 64 | = EntryContent 65 | { entryContentEventStreamId :: Text 66 | , entryContentEventNumber :: Int64 67 | , entryContentEventType :: Text 68 | , entryContentEventId :: EventId 69 | , entryContentData :: Maybe Value 70 | } 71 | deriving (Show) 72 | 73 | data Link 74 | = Link 75 | { linkHref :: Text 76 | , linkRel :: Text 77 | } 78 | deriving (Show) 79 | 80 | buildStreamLink :: Text -> Text -> StreamOffset -> Link 81 | buildStreamLink streamUri rel (direction, position, maxItems)= 82 | let 83 | positionName = case position of EventStartHead -> "head" 84 | EventStartPosition x -> tshow x 85 | directionName = case direction of FeedDirectionForward -> "forward" 86 | FeedDirectionBackward -> "backward" 87 | href = streamUri <> "/" <> positionName <> "/" <> directionName <> "/" <> tshow maxItems 88 | 89 | in Link { linkHref = href, linkRel = rel } 90 | 91 | globalFeedPositionToText :: GlobalFeedPosition -> Text 92 | globalFeedPositionToText GlobalFeedPosition{..} = tshow globalFeedPositionPage <> "-" <> tshow globalFeedPositionOffset 93 | 94 | buildGlobalStreamLink :: Text -> Text -> GlobalStreamOffset -> Link 95 | buildGlobalStreamLink streamUri rel (direction, position, maxItems)= 96 | let 97 | positionName = case position of GlobalStartHead -> "head" 98 | GlobalStartPosition x -> globalFeedPositionToText x 99 | directionName = case direction of FeedDirectionForward -> "forward" 100 | FeedDirectionBackward -> "backward" 101 | href = streamUri <> "/" <> positionName <> "/" <> directionName <> "/" <> tshow maxItems 102 | 103 | in Link { linkHref = href, linkRel = rel } 104 | 105 | genericAuthor :: Author 106 | genericAuthor = Author { authorName = "EventStore" } 107 | 108 | buildFeed :: Text -> Text -> StreamId -> Text -> UTCTime -> [RecordedEvent] -> [Link] -> Feed 109 | buildFeed baseUri title (StreamId streamId) selfuri updated events links = 110 | Feed { 111 | feedId = selfuri 112 | , feedTitle = title 113 | , feedUpdated = updated 114 | , feedSelfUrl = selfuri 115 | , feedStreamId = streamId 116 | , feedAuthor = genericAuthor 117 | , feedLinks = links 118 | , feedEntries = recordedEventToFeedEntry baseUri <$> events 119 | } 120 | 121 | -- adapted from: http://hackage.haskell.org/package/blaze-html-0.3.2.1/docs/src/Text-Blaze-Renderer-Text.html 122 | escapeHtmlEntities :: Text -- ^ Text to escape 123 | -> Text -- ^ Resulting text builder 124 | escapeHtmlEntities = T.foldr escape mempty 125 | where 126 | escape :: Char -> Text -> Text 127 | escape '<' b = "<" `mappend` b 128 | escape '>' b = ">" `mappend` b 129 | escape '&' b = "&" `mappend` b 130 | escape '"' b = """ `mappend` b 131 | escape '\'' b = "'" `mappend` b 132 | escape x b = T.singleton x `mappend` b 133 | 134 | streamResultsToFeed :: Text -> StreamId -> UTCTime -> StreamResult -> Feed 135 | streamResultsToFeed baseUri (StreamId streamId) updated StreamResult{..} = 136 | let 137 | selfuri = baseUri <> "/streams/" <> urlEncode' streamId 138 | buildStreamLink' = buildStreamLink selfuri 139 | links = catMaybes [ 140 | Just Link { linkHref = selfuri, linkRel = "self" } 141 | , buildStreamLink' "first" <$> streamResultFirst 142 | , buildStreamLink' "last" <$> streamResultLast 143 | , buildStreamLink' "next" <$> streamResultNext 144 | , buildStreamLink' "previous" <$> streamResultPrevious 145 | ] 146 | title = "Event stream '" <> escapeHtmlEntities streamId <> "'" 147 | in buildFeed baseUri title (StreamId streamId) selfuri updated streamResultEvents links 148 | 149 | globalStreamResultsToFeed :: Text -> StreamId -> UTCTime -> GlobalStreamResult -> Feed 150 | globalStreamResultsToFeed baseUri streamId updated GlobalStreamResult{..} = 151 | let 152 | selfuri = baseUri <> "/streams/%24all" 153 | buildStreamLink' = buildGlobalStreamLink selfuri 154 | links = catMaybes [ 155 | Just Link { linkHref = selfuri, linkRel = "self" } 156 | , buildStreamLink' "first" <$> globalStreamResultFirst 157 | , buildStreamLink' "last" <$> globalStreamResultLast 158 | , buildStreamLink' "next" <$> globalStreamResultNext 159 | , buildStreamLink' "previous" <$> globalStreamResultPrevious 160 | ] 161 | in buildFeed baseUri "All events" streamId selfuri updated globalStreamResultEvents links 162 | 163 | 164 | recordedEventToFeedEntry :: Text -> RecordedEvent -> Entry 165 | recordedEventToFeedEntry baseUri recordedEvent = 166 | let 167 | streamId = recordedEventStreamId recordedEvent 168 | eventNumber = (tshow . recordedEventNumber) recordedEvent 169 | eventCreated = recordedEventCreated recordedEvent 170 | eventUri = baseUri <> "/streams/" <> urlEncode' streamId <> "/" <> eventNumber 171 | title = eventNumber <> "@" <> streamId 172 | updated = eventCreated 173 | summary = recordedEventType recordedEvent 174 | dataField :: Maybe Value = 175 | if recordedEventIsJson recordedEvent then 176 | let 177 | binaryData = recordedEventData recordedEvent 178 | in APBS.maybeResult (APBS.parse json binaryData) 179 | else Nothing 180 | content = EntryContent { 181 | entryContentEventStreamId = recordedEventStreamId recordedEvent 182 | , entryContentEventNumber = recordedEventNumber recordedEvent 183 | , entryContentEventType = recordedEventType recordedEvent 184 | , entryContentEventId = recordedEventId recordedEvent 185 | , entryContentData = dataField 186 | } 187 | links = [ 188 | Link { linkHref = eventUri, linkRel = "edit" } 189 | , Link { linkHref = eventUri, linkRel = "alternate" } 190 | ] 191 | in Entry { 192 | entryTitle = title 193 | , entryId = eventUri 194 | , entryUpdated = updated 195 | , entrySummary = summary 196 | , entryContent = content 197 | , entryLinks = links 198 | } 199 | 200 | urlEncode' :: Text -> Text 201 | urlEncode' = T.pack . urlEncode . T.unpack 202 | 203 | jsonLink :: Link -> Value 204 | jsonLink Link {..} = 205 | object [ "relation" .= linkRel, "uri" .= linkHref ] 206 | 207 | xmlLink :: Link -> Markup 208 | xmlLink Link {..} = 209 | customLeaf "link" True 210 | ! customAttribute "href" (textValue linkHref) 211 | ! customAttribute "rel" (textValue linkRel) 212 | 213 | xmlEntry :: Entry -> Markup 214 | xmlEntry Entry{..} = 215 | let 216 | entryid = simpleXmlNode "id" entryId 217 | title = simpleXmlNode "title" entryTitle 218 | updated = simpleXmlNode "updated" $ formatJsonTime entryUpdated 219 | summary = simpleXmlNode "summary" entrySummary 220 | links = xmlLink <$> entryLinks 221 | in customParent "entry" $ do 222 | title 223 | entryid 224 | updated 225 | xmlAuthor genericAuthor 226 | summary 227 | forM_ links id 228 | 229 | jsonEntryContent :: EntryContent -> Value 230 | jsonEntryContent EntryContent{..} = 231 | let 232 | addDataField Nothing xs = xs 233 | addDataField (Just x) xs = ("data" .= x):xs 234 | standardFields = [ 235 | "eventStreamId" .= entryContentEventStreamId 236 | , "eventNumber" .= entryContentEventNumber 237 | , "eventId" .= Data.UUID.toText (unEventId entryContentEventId) 238 | , "eventType" .= entryContentEventType] 239 | in object $ addDataField entryContentData standardFields 240 | 241 | jsonAuthor :: Author -> Value 242 | jsonAuthor Author {..} = 243 | object [ "name" .= authorName ] 244 | 245 | simpleXmlNode :: Tag -> Text -> Markup 246 | simpleXmlNode tagName tagContent = 247 | customParent tagName $ text tagContent 248 | 249 | xmlAuthor :: Author -> Markup 250 | xmlAuthor Author {..} = 251 | customParent "author" $ simpleXmlNode "name" authorName 252 | 253 | xmlFeed :: Feed -> Markup 254 | xmlFeed Feed {..} = 255 | let 256 | feed = customParent "feed" ! customAttribute "xmlns" "http://www.w3.org/2005/Atom" 257 | title = customParent "title" (preEscapedText feedTitle) 258 | feedid = simpleXmlNode "id" feedId 259 | updated = simpleXmlNode "updated" $ formatJsonTime feedUpdated 260 | author = xmlAuthor feedAuthor 261 | links = xmlLink <$> feedLinks 262 | entries = xmlEntry <$> feedEntries 263 | in feed $ do 264 | title 265 | feedid 266 | updated 267 | author 268 | forM_ links id 269 | forM_ entries id 270 | 271 | jsonFeed :: Feed -> Value 272 | jsonFeed Feed {..} = 273 | let 274 | title = "title" .= feedTitle 275 | feedid = "id" .= feedId 276 | headofstream = "headOfStream" .= True 277 | updated = "updated" .= formatJsonTime feedUpdated 278 | selfurl = "selfUrl" .= feedSelfUrl 279 | streamid = "streamId" .= feedStreamId 280 | etag = "etag" .= ( "todo" :: Text) 281 | author = "author" .= jsonAuthor feedAuthor 282 | links = "links" .= (Array . V.fromList) (jsonLink <$> feedLinks) 283 | entries = "entries" .= (Array . V.fromList) (jsonEntry <$> feedEntries) 284 | in object [ title, feedid, updated, streamid, author, headofstream, selfurl, etag, links, entries] 285 | 286 | formatJsonTime :: UTCTime -> Text 287 | formatJsonTime utcTime = 288 | let 289 | microseconds = take 6 $ formatTime defaultTimeLocale "%q" utcTime 290 | dateAndTime = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" utcTime 291 | in T.pack $ dateAndTime <> "." <> microseconds <> "Z" 292 | 293 | jsonEntry :: Entry -> Value 294 | jsonEntry Entry{..} = 295 | let 296 | entryid = "id" .= entryId 297 | title = "title" .= entryTitle 298 | author = "author" .= (jsonAuthor genericAuthor) 299 | updated = "updated" .= formatJsonTime entryUpdated 300 | summary = "summary" .= entrySummary 301 | content = "content" .= jsonEntryContent entryContent 302 | links = "links" .= (Array . V.fromList) (jsonLink <$> entryLinks) 303 | in object [entryid, author, title, summary, content, links, updated] 304 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/src/DynamoDbEventStore/GlobalPaging.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module DynamoDbEventStore.GlobalPaging 4 | (GlobalStreamResult(..) 5 | ,GlobalStreamOffset 6 | ,GlobalStartPosition(..) 7 | ,ReadAllRequest(..) 8 | ,runGlobalStreamRequest) 9 | 10 | where 11 | 12 | import DynamoDbEventStore.ProjectPrelude 13 | import qualified Pipes.Prelude as P 14 | import Safe 15 | import DynamoDbEventStore.Paging (FeedDirection(..)) 16 | import DynamoDbEventStore.Types ( 17 | GlobalFeedPosition(..), 18 | QueryDirection(..), 19 | EventKey(..), 20 | RecordedEvent(..)) 21 | 22 | data ReadAllRequest = ReadAllRequest { 23 | readAllRequestStartPosition :: Maybe GlobalFeedPosition 24 | , readAllRequestMaxItems :: Natural 25 | , readAllRequestDirection :: FeedDirection 26 | } deriving (Show) 27 | 28 | data GlobalStartPosition = GlobalStartHead | GlobalStartPosition GlobalFeedPosition deriving (Show, Eq) 29 | 30 | data GlobalStreamResult = GlobalStreamResult { 31 | globalStreamResultEvents :: [RecordedEvent] 32 | , globalStreamResultFirst :: Maybe GlobalStreamOffset 33 | , globalStreamResultNext :: Maybe GlobalStreamOffset 34 | , globalStreamResultPrevious :: Maybe GlobalStreamOffset 35 | , globalStreamResultLast :: Maybe GlobalStreamOffset 36 | } deriving Show 37 | 38 | type GlobalStreamOffset = (FeedDirection, GlobalStartPosition, Natural) 39 | 40 | runGlobalStreamRequest 41 | :: Monad m 42 | => (QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, RecordedEvent) m ()) 43 | -> (QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, EventKey) m ()) 44 | -> ReadAllRequest 45 | -> m GlobalStreamResult 46 | runGlobalStreamRequest eventProducer eventKeyProducer ReadAllRequest 47 | { 48 | readAllRequestDirection = FeedDirectionForward 49 | , readAllRequestStartPosition = readAllRequestStartPosition 50 | , readAllRequestMaxItems = readAllRequestMaxItems 51 | } = do 52 | events <- P.toListM $ 53 | eventProducer QueryDirectionForward readAllRequestStartPosition 54 | >-> P.take (fromIntegral readAllRequestMaxItems) 55 | let previousEventPosition = fst <$> lastMay events 56 | nextEvent <- case readAllRequestStartPosition of Nothing -> return Nothing 57 | Just startPosition -> do 58 | nextEvents <- P.toListM $ 59 | eventKeyProducer QueryDirectionBackward (Just startPosition) 60 | >-> P.map fst 61 | >-> P.filter (<= startPosition) 62 | >-> P.take 1 63 | return $ listToMaybe nextEvents 64 | return GlobalStreamResult { 65 | globalStreamResultEvents = snd <$> events, 66 | globalStreamResultNext = (\pos -> (FeedDirectionBackward, GlobalStartPosition pos, readAllRequestMaxItems)) <$> nextEvent, 67 | globalStreamResultPrevious = (\pos -> (FeedDirectionForward, GlobalStartPosition pos, readAllRequestMaxItems)) <$> previousEventPosition, 68 | globalStreamResultFirst = Just (FeedDirectionBackward, GlobalStartHead, readAllRequestMaxItems), 69 | globalStreamResultLast = const (FeedDirectionForward, GlobalStartHead, readAllRequestMaxItems) <$> nextEvent -- only show last if there is a next 70 | } 71 | runGlobalStreamRequest eventProducer _eventKeyProducer ReadAllRequest 72 | { 73 | readAllRequestDirection = FeedDirectionBackward 74 | , readAllRequestStartPosition = readAllRequestStartPosition 75 | , readAllRequestMaxItems = readAllRequestMaxItems 76 | } = do 77 | let maxItems = fromIntegral readAllRequestMaxItems 78 | eventsPlus1 <- P.toListM $ 79 | eventProducer QueryDirectionBackward readAllRequestStartPosition 80 | >-> filterLastEvent readAllRequestStartPosition 81 | >-> P.take (maxItems + 1) 82 | let events = snd <$> take maxItems eventsPlus1 83 | let previousEventPosition = fst <$> headMay eventsPlus1 84 | let nextEventBackwardPosition = fst <$> listToMaybe (drop maxItems eventsPlus1) 85 | return GlobalStreamResult { 86 | globalStreamResultEvents = events, 87 | globalStreamResultNext = (\pos -> (FeedDirectionBackward, GlobalStartPosition pos, readAllRequestMaxItems)) <$> nextEventBackwardPosition, 88 | globalStreamResultPrevious = (\pos -> (FeedDirectionForward, GlobalStartPosition pos, readAllRequestMaxItems)) <$> previousEventPosition, 89 | globalStreamResultFirst = Just (FeedDirectionBackward, GlobalStartHead, readAllRequestMaxItems), 90 | globalStreamResultLast = const (FeedDirectionForward, GlobalStartHead, readAllRequestMaxItems) <$> nextEventBackwardPosition -- only show last if there is a next 91 | } 92 | where 93 | filterLastEvent Nothing = P.filter (const True) 94 | filterLastEvent (Just startPosition) = P.filter ((<= startPosition) . fst) 95 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/src/DynamoDbEventStore/Paging.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module DynamoDbEventStore.Paging 3 | (runStreamRequest 4 | ,FeedDirection(..) 5 | ,StreamResult(..) 6 | ,EventStartPosition(..) 7 | ,ReadStreamRequest(..) 8 | ,StreamOffset) 9 | where 10 | 11 | import DynamoDbEventStore.ProjectPrelude 12 | import qualified Test.QuickCheck as QC 13 | import qualified Pipes.Prelude as P 14 | import Safe 15 | import DynamoDbEventStore.Types (RecordedEvent(..), StreamId, QueryDirection(..)) 16 | 17 | data FeedDirection = FeedDirectionForward | FeedDirectionBackward 18 | deriving (Eq, Show) 19 | 20 | instance QC.Arbitrary FeedDirection where 21 | arbitrary = QC.elements [FeedDirectionForward, FeedDirectionBackward] 22 | 23 | data EventStartPosition = EventStartHead | EventStartPosition Int64 deriving (Show, Eq) 24 | 25 | type StreamOffset = (FeedDirection, EventStartPosition, Natural) 26 | 27 | data StreamResult = StreamResult { 28 | streamResultEvents :: [RecordedEvent] 29 | , streamResultFirst :: Maybe StreamOffset 30 | , streamResultNext :: Maybe StreamOffset 31 | , streamResultPrevious :: Maybe StreamOffset 32 | , streamResultLast :: Maybe StreamOffset 33 | } deriving Show 34 | 35 | data ReadStreamRequest = ReadStreamRequest { 36 | rsrStreamId :: StreamId, 37 | rsrStartEventNumber :: Maybe Int64, 38 | rsrMaxItems :: Natural, 39 | rsrDirection :: FeedDirection 40 | } deriving (Show) 41 | 42 | buildStreamResult :: FeedDirection -> Maybe Int64 -> [RecordedEvent] -> Maybe Int64 -> Natural -> Maybe StreamResult 43 | buildStreamResult _ Nothing _ _ _ = Nothing 44 | buildStreamResult FeedDirectionBackward (Just lastEvent) events requestedStartEventNumber maxItems = 45 | let 46 | maxEventNumber = maximum $ recordedEventNumber <$> events 47 | startEventNumber = fromMaybe maxEventNumber requestedStartEventNumber 48 | nextEventNumber = startEventNumber - fromIntegral maxItems 49 | in Just StreamResult { 50 | streamResultEvents = events, 51 | streamResultFirst = Just (FeedDirectionBackward, EventStartHead, maxItems), 52 | streamResultNext = 53 | if nextEventNumber >= 0 then 54 | Just (FeedDirectionBackward, EventStartPosition nextEventNumber, maxItems) 55 | else Nothing, 56 | streamResultPrevious = Just (FeedDirectionForward, EventStartPosition (min (startEventNumber + 1) (lastEvent + 1)), maxItems), 57 | streamResultLast = 58 | if nextEventNumber >= 0 then 59 | Just (FeedDirectionForward, EventStartPosition 0, maxItems) 60 | else Nothing 61 | } 62 | buildStreamResult FeedDirectionForward (Just _lastEvent) events requestedStartEventNumber maxItems = 63 | let 64 | maxEventNumber = maximumMay $ recordedEventNumber <$> events 65 | minEventNumber = minimumMay $ recordedEventNumber <$> events 66 | nextEventNumber = fromMaybe (fromMaybe 0 ((\x -> x - 1) <$> requestedStartEventNumber)) ((\x -> x - 1) <$> minEventNumber) 67 | previousEventNumber = (+1) <$> maxEventNumber 68 | in Just StreamResult { 69 | streamResultEvents = events, 70 | streamResultFirst = Just (FeedDirectionBackward, EventStartHead, maxItems), 71 | streamResultNext = 72 | if nextEventNumber >= 0 then 73 | Just (FeedDirectionBackward, EventStartPosition nextEventNumber, maxItems) 74 | else Nothing, 75 | streamResultPrevious = (\eventNumber -> (FeedDirectionForward, EventStartPosition eventNumber, maxItems)) <$> previousEventNumber, 76 | streamResultLast = 77 | if maybe True (> 0) minEventNumber then 78 | Just (FeedDirectionForward, EventStartPosition 0, maxItems) 79 | else Nothing 80 | } 81 | 82 | getLastEvent 83 | :: (Monad m) 84 | => (QueryDirection -> StreamId -> Maybe Int64 -> Natural -> Producer RecordedEvent m ()) 85 | -> StreamId 86 | -> m (Maybe Int64) 87 | getLastEvent eventProducer streamId = do 88 | x <- P.head $ eventProducer QueryDirectionBackward streamId Nothing 1 89 | return $ recordedEventNumber <$> x 90 | 91 | runStreamRequest 92 | :: (Monad m) 93 | => (QueryDirection -> StreamId -> Maybe Int64 -> Natural -> Producer RecordedEvent m ()) 94 | -> ReadStreamRequest 95 | -> m (Maybe StreamResult) 96 | runStreamRequest eventProducer (ReadStreamRequest streamId startEventNumber maxItems FeedDirectionBackward) = 97 | do 98 | lastEvent <- getLastEvent eventProducer streamId 99 | events <- 100 | P.toListM $ 101 | eventProducer QueryDirectionBackward streamId startEventNumber 10 102 | >-> filterLastEvent startEventNumber 103 | >-> maxItemsFilter startEventNumber 104 | return $ buildStreamResult FeedDirectionBackward lastEvent events startEventNumber maxItems 105 | where 106 | maxItemsFilter Nothing = P.take (fromIntegral maxItems) 107 | maxItemsFilter (Just v) = P.takeWhile (\r -> recordedEventNumber r > minimumEventNumber v) 108 | minimumEventNumber start = fromIntegral start - fromIntegral maxItems 109 | filterLastEvent Nothing = P.filter (const True) 110 | filterLastEvent (Just v) = P.filter ((<= v) . recordedEventNumber) 111 | runStreamRequest eventProducer (ReadStreamRequest streamId startEventNumber maxItems FeedDirectionForward) = 112 | do 113 | lastEvent <- getLastEvent eventProducer streamId 114 | events <- 115 | P.toListM $ 116 | eventProducer QueryDirectionForward streamId startEventNumber 10 117 | >-> filterFirstEvent startEventNumber 118 | >-> maxItemsFilter startEventNumber 119 | return $ buildStreamResult FeedDirectionForward lastEvent events startEventNumber maxItems 120 | where 121 | maxItemsFilter Nothing = P.take (fromIntegral maxItems) 122 | maxItemsFilter (Just v) = P.takeWhile (\r -> recordedEventNumber r <= maximumEventNumber v) 123 | maximumEventNumber start = fromIntegral start + fromIntegral maxItems - 1 124 | filterFirstEvent Nothing = P.filter (const True) 125 | filterFirstEvent (Just v) = P.filter ((>= v) . recordedEventNumber) 126 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/src/DynamoDbEventStore/Webserver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | 9 | module DynamoDbEventStore.Webserver( 10 | app 11 | , positiveInt64Parser 12 | , runParser 13 | , realRunner 14 | , EventStoreActionRunner(..) 15 | , parseGlobalFeedPosition 16 | , globalFeedPositionToText 17 | , knownJsonKeyOrder 18 | ) where 19 | 20 | import BasicPrelude 21 | import Web.Scotty.Trans 22 | 23 | import Control.Arrow (left) 24 | import Control.Monad.Except 25 | import Control.Monad.Reader 26 | import Data.Aeson 27 | import Data.Aeson.Encode.Pretty 28 | import Data.Attoparsec.Text.Lazy 29 | import Data.Char (isDigit) 30 | import Data.List.NonEmpty (NonEmpty (..)) 31 | import qualified Data.Text.Lazy as TL 32 | import qualified Data.Text.Lazy.Encoding as TL 33 | import Data.Time.Clock (UTCTime) 34 | import qualified Data.Time.Clock as Time 35 | import Data.Time.Format 36 | import qualified Data.UUID as UUID 37 | import DynamoDbEventStore 38 | import DynamoDbEventStore.EventStoreActions 39 | import DynamoDbEventStore.Paging 40 | import DynamoDbEventStore.EventStoreCommands 41 | import DynamoDbEventStore.Types 42 | import DynamoDbEventStore.Feed 43 | import Network.HTTP.Types.Status 44 | import Text.Blaze.Renderer.Text 45 | 46 | data ExpectedVersion = ExpectedVersion Int 47 | deriving (Show) 48 | 49 | toByteString :: LText -> ByteString 50 | toByteString = encodeUtf8 . TL.toStrict 51 | 52 | error400 :: (MonadIO m) => LText -> ActionT e m () 53 | error400 err = status $ mkStatus 400 (toByteString err) 54 | 55 | error500 :: (MonadIO m) => LText -> ActionT e m () 56 | error500 err = status $ mkStatus 500 (toByteString err) 57 | 58 | runParser :: Parser a -> e -> LText -> Either e a 59 | runParser p e = left (const e) . eitherResult . parse p 60 | 61 | headerError :: LText -> LText -> LText 62 | headerError headerName message = 63 | mconcat [headerName, " header ", message] 64 | 65 | maybeToEither :: a -> Maybe b ->Either a b 66 | maybeToEither a Nothing = Left a 67 | maybeToEither _ (Just a) = Right a 68 | 69 | globalFeedPositionParser :: Parser GlobalFeedPosition 70 | globalFeedPositionParser = 71 | GlobalFeedPosition 72 | <$> pageKeyParser 73 | <*> (string "-" *> positiveIntParser) 74 | 75 | parseGlobalFeedPosition :: Text -> Maybe GlobalFeedPosition 76 | parseGlobalFeedPosition = 77 | maybeResult . parse (globalFeedPositionParser <* endOfInput) . TL.fromStrict 78 | 79 | parseMandatoryHeader :: (MonadIO m, ScottyError e) => LText -> Parser a -> ActionT e m (Either LText a) 80 | parseMandatoryHeader headerName parser = do 81 | headerText <- header headerName 82 | return $ 83 | maybeToEither missingErrorText headerText 84 | >>= runParser parser parseFailErrorText 85 | where 86 | missingErrorText = headerError headerName "is missing" 87 | parseFailErrorText = headerError headerName "in wrong format" 88 | 89 | parseOptionalHeader :: (MonadIO m, ScottyError e) => LText -> Parser a -> ActionT e m (Either LText (Maybe a)) 90 | parseOptionalHeader headerName parser = do 91 | headerValue <- header headerName 92 | case headerValue of Nothing -> return $ Right Nothing 93 | Just headerText -> return $ Just <$> (Right headerText >>= runParser parser parseFailErrorText) 94 | where 95 | parseFailErrorText = headerError headerName "in wrong format" 96 | 97 | maxInt64 :: Integer 98 | maxInt64 = toInteger (maxBound :: Int64) 99 | 100 | positiveIntegerParser :: Parser Integer 101 | positiveIntegerParser = 102 | (read . fromString) <$> many1 (satisfy isDigit) 103 | 104 | textParser :: Parser Text 105 | textParser = 106 | fmap fromString $ many1 (satisfy (const True)) <* endOfInput 107 | 108 | uuidParser :: Parser UUID.UUID 109 | uuidParser = do 110 | t <- textParser 111 | case UUID.fromText t of Nothing -> fail "Could not parse UUID" 112 | (Just v) -> return v 113 | 114 | acceptHeaderToIsJsonParser :: Parser Bool 115 | acceptHeaderToIsJsonParser = 116 | let 117 | jsonParser = asciiCI "application/json" >> return True 118 | binaryParser = asciiCI "application/octet-stream" >> return False 119 | in jsonParser <|> binaryParser <|> fail "unrecognized content type" 120 | 121 | positiveIntParser :: Parser Int 122 | positiveIntParser = 123 | filterInt =<< positiveIntegerParser 124 | where 125 | filterInt :: Integer -> Parser Int 126 | filterInt a 127 | | a <= toInteger (maxBound :: Int) = return (fromInteger a) 128 | | otherwise = fail "too large" 129 | 130 | positiveInt64Parser :: Parser Int64 131 | positiveInt64Parser = 132 | filterInt64 =<< positiveIntegerParser 133 | where 134 | filterInt64 :: Integer -> Parser Int64 135 | filterInt64 a 136 | | a <= maxInt64 = return (fromInteger a) 137 | | otherwise = fail "too large" 138 | 139 | pageKeyParser :: Parser PageKey 140 | pageKeyParser = PageKey <$> positiveInt64Parser 141 | 142 | readEventResultJsonValue :: Text -> RecordedEvent -> Value 143 | readEventResultJsonValue baseUri recordedEvent = 144 | jsonEntry $ recordedEventToFeedEntry baseUri recordedEvent 145 | 146 | eventStorePostResultToText :: (MonadIO m) => ResponseEncoding -> PostEventResult -> ActionT e m () 147 | eventStorePostResultToText _ (PostEventResult r) = (raw . TL.encodeUtf8 . TL.fromStrict) $ tshow r 148 | 149 | notFoundResponse :: (MonadIO m, ScottyError e) => ActionT e m () 150 | notFoundResponse = status (mkStatus 404 (toByteString "Not Found")) >> raw "{}" 151 | 152 | knownJsonKeyOrder :: [Text] 153 | knownJsonKeyOrder = [ 154 | "title" 155 | , "id" 156 | , "updated" 157 | , "author" 158 | , "summary" 159 | , "content" 160 | , "links" 161 | , "eventStreamId" 162 | , "eventNumber" 163 | , "eventType" 164 | , "eventId" 165 | , "data" 166 | , "metadata" 167 | ] 168 | 169 | encodeJson :: ToJSON a => a -> LByteString 170 | encodeJson = encodePretty' defConfig { 171 | confIndent = Spaces 2 172 | , confCompare = keyOrder knownJsonKeyOrder } 173 | 174 | eventStoreReadEventResultToText :: (MonadIO m, ScottyError e) => Text -> ResponseEncoding -> ReadEventResult -> ActionT e m () 175 | eventStoreReadEventResultToText _ _ (ReadEventResult (Left err)) = (error500 . TL.fromStrict . tshow) err 176 | eventStoreReadEventResultToText baseUri AtomJsonEncoding (ReadEventResult (Right (Just r))) = (raw . encodeJson . readEventResultJsonValue baseUri) r 177 | eventStoreReadEventResultToText baseUri AtomXmlEncoding (ReadEventResult (Right (Just r))) = (raw . encodeJson . readEventResultJsonValue baseUri) r -- todo this isn't right 178 | eventStoreReadEventResultToText _ _ (ReadEventResult (Right Nothing)) = notFoundResponse 179 | 180 | encodeFeed :: (MonadIO m) => ResponseEncoding -> Feed -> ActionT e m () 181 | encodeFeed AtomJsonEncoding = raw . encodeJson . jsonFeed 182 | encodeFeed AtomXmlEncoding = raw . TL.encodeUtf8 . ("" <>) . renderMarkup . xmlFeed 183 | 184 | eventStoreReadStreamResultToText :: (MonadIO m, ScottyError e) => Text -> StreamId -> ResponseEncoding -> ReadStreamResult -> ActionT e m () 185 | eventStoreReadStreamResultToText _ _ _ (ReadStreamResult (Left err)) = (error500 . TL.fromStrict . tshow) err 186 | eventStoreReadStreamResultToText _ _streamId _ (ReadStreamResult (Right Nothing)) = notFoundResponse 187 | eventStoreReadStreamResultToText baseUri streamId encoding (ReadStreamResult (Right (Just streamResult))) = 188 | let 189 | sampleTime = parseTimeOrError True defaultTimeLocale rfc822DateFormat "Sun, 08 May 2016 12:49:41 +0000" -- todo 190 | buildFeed' = streamResultsToFeed baseUri streamId sampleTime 191 | in encodeFeed encoding . buildFeed' $ streamResult 192 | 193 | eventStoreReadAllResultToText :: (MonadIO m) => Text -> ResponseEncoding -> ReadAllResult -> ActionT e m () 194 | eventStoreReadAllResultToText _ _ (ReadAllResult (Left err)) = (error500 . TL.fromStrict . tshow) err 195 | eventStoreReadAllResultToText baseUri encoding (ReadAllResult (Right globalStreamResult)) = 196 | let 197 | streamId = StreamId "%24all" 198 | sampleTime = parseTimeOrError True defaultTimeLocale rfc822DateFormat "Sun, 08 May 2016 12:49:41 +0000" -- todo 199 | buildFeed' = globalStreamResultsToFeed baseUri streamId sampleTime 200 | in encodeFeed encoding . buildFeed' $ globalStreamResult 201 | 202 | data ResponseEncoding = AtomJsonEncoding | AtomXmlEncoding 203 | 204 | notEmpty :: Text -> Either LText Text 205 | notEmpty "" = Left "streamId required" 206 | notEmpty t = Right t 207 | 208 | class MonadHasTime m where 209 | getCurrentTime :: m UTCTime 210 | 211 | instance MonadHasTime IO where 212 | getCurrentTime = Time.getCurrentTime 213 | 214 | instance (Monad m) => MonadHasTime (ReaderT UTCTime m) where 215 | getCurrentTime = ask 216 | 217 | data WebError = 218 | UnknownAcceptValue 219 | | WebErrorInterpreter EventStoreError 220 | deriving Show 221 | 222 | data EventStoreActionRunner = EventStoreActionRunner { 223 | eventStoreActionRunnerPostEvent :: PostEventRequest -> IO PostEventResult 224 | , eventStoreActionRunnerReadStream :: ReadStreamRequest -> IO ReadStreamResult 225 | , eventStoreActionRunnerReadAll :: ReadAllRequest -> IO ReadAllResult 226 | , eventStoreActionRunnerReadEvent :: ReadEventRequest -> IO ReadEventResult 227 | } 228 | 229 | getEncoding :: forall m. forall e. (Monad m, ScottyError e) => ExceptT WebError (ActionT e m) ResponseEncoding 230 | getEncoding = do 231 | accept <- lift $ header "Accept" 232 | case accept of (Just "application/vnd.eventstore.atom+json") -> return AtomJsonEncoding 233 | (Just "application/atom+xml") -> return AtomXmlEncoding 234 | _ -> throwError UnknownAcceptValue 235 | 236 | runActionWithEncodedResponse :: (MonadIO m, ScottyError e) => IO r -> (ResponseEncoding -> r -> ActionT e m ()) -> ActionT e m () 237 | runActionWithEncodedResponse runAction processResponse = runExceptT (do 238 | encoding <- getEncoding 239 | result <- liftAction runAction 240 | return (encoding, result)) >>= \case 241 | (Left err) -> (error500 . TL.fromStrict . tshow) err 242 | (Right (encoding, a)) -> processResponse encoding a 243 | where 244 | liftAction :: (MonadIO m, ScottyError e) => IO r -> ExceptT WebError (ActionT e m) r 245 | liftAction f = do 246 | r <- liftIO f 247 | return r 248 | 249 | realRunner :: Text -> EventStoreActionRunner -> Process 250 | realRunner _baseUri mainRunner (PostEvent postEventRequest) = 251 | runActionWithEncodedResponse 252 | (eventStoreActionRunnerPostEvent mainRunner postEventRequest) 253 | eventStorePostResultToText 254 | realRunner baseUri mainRunner (ReadEvent readEventRequest) = 255 | runActionWithEncodedResponse 256 | (eventStoreActionRunnerReadEvent mainRunner readEventRequest) 257 | (eventStoreReadEventResultToText baseUri) 258 | realRunner baseUri mainRunner (ReadStream readStreamRequest@ReadStreamRequest{..}) = 259 | runActionWithEncodedResponse 260 | (eventStoreActionRunnerReadStream mainRunner readStreamRequest) 261 | (eventStoreReadStreamResultToText baseUri rsrStreamId) 262 | realRunner baseUri mainRunner (ReadAll readAllRequest) = 263 | runActionWithEncodedResponse 264 | (eventStoreActionRunnerReadAll mainRunner readAllRequest) 265 | (eventStoreReadAllResultToText baseUri) 266 | 267 | type Process = forall m. forall e. (MonadIO m, ScottyError e) => EventStoreAction -> ActionT e m () 268 | 269 | globalFeedStartPositionParser :: Parser GlobalStartPosition 270 | globalFeedStartPositionParser = 271 | let 272 | headParser = (const GlobalStartHead <$> string "head") 273 | eventNumberParser = GlobalStartPosition <$> globalFeedPositionParser 274 | in (headParser <|> eventNumberParser) <* endOfInput 275 | 276 | eventStartPositionParser :: Parser EventStartPosition 277 | eventStartPositionParser = 278 | let 279 | headParser = (const EventStartHead <$> string "head") 280 | eventNumberParser = EventStartPosition <$> positiveInt64Parser 281 | in (headParser <|> eventNumberParser) <* endOfInput 282 | 283 | eventStartPositionToMaybeInt64 :: Maybe EventStartPosition -> Maybe Int64 284 | eventStartPositionToMaybeInt64 Nothing = Nothing 285 | eventStartPositionToMaybeInt64 (Just EventStartHead) = Nothing 286 | eventStartPositionToMaybeInt64 (Just (EventStartPosition x)) = Just x 287 | 288 | globalStartPositionToMaybeInt64 :: Maybe GlobalStartPosition -> Maybe GlobalFeedPosition 289 | globalStartPositionToMaybeInt64 Nothing = Nothing 290 | globalStartPositionToMaybeInt64 (Just GlobalStartHead) = Nothing 291 | globalStartPositionToMaybeInt64 (Just (GlobalStartPosition x)) = Just x 292 | 293 | readOptionalParameter :: (Read a, Monad m, ScottyError e) => LText -> Maybe (ActionT e m Text) -> ActionT e m (Either LText (Maybe a)) 294 | readOptionalParameter errorMsg parameter = 295 | let parseValue t = maybe (Left errorMsg) (Right . Just) (readMay t) 296 | in maybe (return $ Right Nothing) (fmap parseValue) parameter 297 | 298 | parseOptionalParameter :: (Monad m, ScottyError e) => LText -> Parser a -> Maybe (ActionT e m Text) -> ActionT e m (Either LText (Maybe a)) 299 | parseOptionalParameter errorMsg parser parameter = 300 | let parseValue t = Just <$> runParser parser errorMsg (TL.fromStrict t) 301 | in maybe (return $ Right Nothing) (fmap parseValue) parameter 302 | 303 | toResult' :: (MonadIO m, ScottyError e) => Process -> Either LText EventStoreAction -> ActionT e m () 304 | toResult' _ (Left err) = error400 err 305 | toResult' process (Right action) = process action 306 | 307 | readStreamHandler :: (MonadIO m, ScottyError e) => Process -> ActionT e m Text -> Maybe (ActionT e m Text) -> Maybe (ActionT e m Text) -> FeedDirection -> ActionT e m () 308 | readStreamHandler process streamIdAction startEventParameter eventCountParameter feedDirection = do 309 | streamId <- streamIdAction 310 | eventCount <- readOptionalParameter "Invalid event count" eventCountParameter 311 | if streamId == "$all" || streamId == "%24all" then do 312 | startPosition <- parseOptionalParameter "Invalid global position" globalFeedStartPositionParser startEventParameter 313 | toResult' process (ReadAll <$> (ReadAllRequest 314 | <$> (globalStartPositionToMaybeInt64 <$> startPosition) 315 | <*> (fromMaybe 20 <$> eventCount) 316 | <*> Right feedDirection)) 317 | else do 318 | startEvent <- parseOptionalParameter "Invalid event number" eventStartPositionParser startEventParameter 319 | toResult' process (ReadStream <$> (ReadStreamRequest 320 | <$> (StreamId <$> notEmpty streamId) 321 | <*> (eventStartPositionToMaybeInt64 <$> startEvent) 322 | <*> (fromMaybe 20 <$> eventCount) 323 | <*> Right feedDirection)) 324 | 325 | postEventHandler :: (MonadIO m, MonadHasTime m, ScottyError e) => Process -> ActionT e m () 326 | postEventHandler process = do 327 | streamId <- param "streamId" 328 | expectedVersion <- parseOptionalHeader "ES-ExpectedVersion" (positiveInt64Parser <* endOfInput) 329 | eventType <- parseMandatoryHeader "ES-EventType" textParser 330 | eventData <- body 331 | eventTime <- lift getCurrentTime 332 | eventId <- parseMandatoryHeader "ES-EventId" uuidParser 333 | isJson <- parseMandatoryHeader "Content-Type" acceptHeaderToIsJsonParser 334 | let eventEntries = 335 | EventEntry 336 | <$> pure eventData 337 | <*> (EventType <$> eventType) 338 | <*> (EventId <$> eventId) 339 | <*> pure (EventTime eventTime) 340 | <*> isJson 341 | toResult' process (PostEvent <$> (PostEventRequest 342 | <$> pure streamId 343 | <*> expectedVersion 344 | <*> ((\x -> x:|[]) <$> eventEntries))) 345 | app :: (MonadIO m, MonadHasTime m, ScottyError e) => Process -> ScottyT e m () 346 | app process = do 347 | post "/streams/:streamId" $ postEventHandler process 348 | get "/streams/:streamId/:eventNumber" $ do 349 | streamId <- param "streamId" 350 | eventNumber <- param "eventNumber" 351 | toResult' process (ReadEvent <$> (ReadEventRequest 352 | <$> notEmpty streamId 353 | <*> runParser (positiveInt64Parser <* endOfInput) "Invalid Event Number" eventNumber)) 354 | get "/streams/:streamId" $ readStreamHandler process (param "streamId") Nothing Nothing FeedDirectionBackward 355 | get "/streams/:streamId/:eventNumber/:count" $ readStreamHandler process (param "streamId") (Just $ param "eventNumber") (Just $ param "count") FeedDirectionBackward 356 | get "/streams/:streamId/:eventNumber/backward/:count" $ readStreamHandler process (param "streamId") (Just $ param "eventNumber") (Just $ param "count") FeedDirectionBackward 357 | get "/streams/:streamId/:eventNumber/forward/:count" $ readStreamHandler process (param "streamId") (Just $ param "eventNumber") (Just $ param "count") FeedDirectionForward 358 | notFound $ status status404 359 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/tests/DynamoDbEventStore/FeedOutputSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DynamoDbEventStore.FeedOutputSpec (tests) where 4 | 5 | import BasicPrelude 6 | import Data.Aeson 7 | import Data.Aeson.Encode.Pretty 8 | import Data.Maybe (fromJust) 9 | import Data.Time.Format 10 | import qualified Data.UUID as UUID 11 | import DynamoDbEventStore.EventStoreActions 12 | import DynamoDbEventStore.Paging 13 | import DynamoDbEventStore.EventStoreCommands 14 | import DynamoDbEventStore.Types 15 | import DynamoDbEventStore.Feed 16 | import DynamoDbEventStore.Webserver 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | import Text.Blaze.Renderer.String 20 | 21 | -- a set of tests that will detect unexpected changes in converting feeds/entries to 22 | -- or from their feed types 23 | -- ideally unit tests should catch these errors 24 | 25 | globalFeedXmlOutputCheck :: Assertion 26 | globalFeedXmlOutputCheck = 27 | let 28 | baseUri = "http://localhost:2113" 29 | streamId = StreamId "%24all" 30 | sampleTime = parseTimeOrError True defaultTimeLocale rfc822DateFormat "Sun, 08 May 2016 12:49:41 +0000" -- todo 31 | buildFeed = globalStreamResultsToFeed baseUri streamId sampleTime globalFeedResult 32 | globalFeedResult = GlobalStreamResult { 33 | globalStreamResultEvents = [ 34 | RecordedEvent{ 35 | recordedEventStreamId = "MyStream" 36 | , recordedEventNumber = 2 37 | , recordedEventData = fromString "{ \"a\": 2 }" 38 | , recordedEventType = "Event Type" 39 | , recordedEventCreated = sampleTime 40 | , recordedEventId = EventId (fromJust $ UUID.fromString "1449f441-e249-4381-92b8-a3e2a444c95c") 41 | , recordedEventIsJson = True 42 | }] 43 | , globalStreamResultFirst = Just (FeedDirectionForward, GlobalStartHead, 1) 44 | , globalStreamResultLast = Nothing 45 | , globalStreamResultNext = Nothing 46 | , globalStreamResultPrevious = Nothing} 47 | 48 | expectedXml = "All eventshttp://localhost:2113/streams/%24all2016-05-08T12:49:41.000000ZEventStore2@MyStreamhttp://localhost:2113/streams/MyStream/22016-05-08T12:49:41.000000ZEventStoreEvent Type" 49 | in assertEqual "feed is equal to expected xml" expectedXml (renderMarkup $ xmlFeed buildFeed) 50 | 51 | streamFeedXmlOutputCheck :: Assertion 52 | streamFeedXmlOutputCheck = 53 | let 54 | baseUri = "http://localhost:2113" 55 | streamId = StreamId "MyStream" 56 | sampleTime = parseTimeOrError True defaultTimeLocale rfc822DateFormat "Sun, 08 May 2016 12:49:41 +0000" -- todo 57 | buildFeed = streamResultsToFeed baseUri streamId sampleTime streamResult 58 | streamResult = StreamResult { 59 | streamResultEvents = [ 60 | RecordedEvent{ 61 | recordedEventStreamId = "MyStream" 62 | , recordedEventNumber = 2 63 | , recordedEventData = fromString "{ \"a\": 2 }" 64 | , recordedEventType = "Event Type" 65 | , recordedEventCreated = sampleTime 66 | , recordedEventId = EventId (fromJust $ UUID.fromString "1449f441-e249-4381-92b8-a3e2a444c95c") 67 | , recordedEventIsJson = True 68 | }] 69 | , streamResultFirst = Just (FeedDirectionForward, EventStartHead, 1) 70 | , streamResultLast = Nothing 71 | , streamResultNext = Nothing 72 | , streamResultPrevious = Nothing} 73 | 74 | expectedXml = "Event stream 'MyStream'http://localhost:2113/streams/MyStream2016-05-08T12:49:41.000000ZEventStore2@MyStreamhttp://localhost:2113/streams/MyStream/22016-05-08T12:49:41.000000ZEventStoreEvent Type" 75 | in assertEqual "feed is equal to expected xml" expectedXml (renderMarkup $ xmlFeed buildFeed) 76 | 77 | encodeJson :: ToJSON a => a -> LByteString 78 | encodeJson = encodePretty' defConfig { 79 | confIndent = Spaces 2 80 | , confCompare = keyOrder knownJsonKeyOrder } 81 | 82 | readEventResultJsonValue :: Text -> RecordedEvent -> Value 83 | readEventResultJsonValue baseUri recordedEvent = 84 | jsonEntry $ recordedEventToFeedEntry baseUri recordedEvent 85 | 86 | eventJsonOutputCheck :: Assertion 87 | eventJsonOutputCheck = 88 | let 89 | baseUri = "http://localhost:2113" 90 | sampleTime = parseTimeOrError True defaultTimeLocale rfc822DateFormat "Sun, 08 May 2016 12:49:41 +0000" -- todo 91 | buildFeed = encodeJson $ readEventResultJsonValue baseUri recordedEvent 92 | recordedEvent = RecordedEvent{ 93 | recordedEventStreamId = "MyStream" 94 | , recordedEventNumber = 2 95 | , recordedEventData = fromString "{ \"a\": 2 }" 96 | , recordedEventType = "Event Type" 97 | , recordedEventCreated = sampleTime 98 | , recordedEventId = EventId (fromJust $ UUID.fromString "1449f441-e249-4381-92b8-a3e2a444c95c") 99 | , recordedEventIsJson = True 100 | } 101 | 102 | expectedJson = "{\n \"title\": \"2@MyStream\",\n \"id\": \"http://localhost:2113/streams/MyStream/2\",\n \"updated\": \"2016-05-08T12:49:41.000000Z\",\n \"author\": {\n \"name\": \"EventStore\"\n },\n \"summary\": \"Event Type\",\n \"content\": {\n \"eventStreamId\": \"MyStream\",\n \"eventNumber\": 2,\n \"eventType\": \"Event Type\",\n \"eventId\": \"1449f441-e249-4381-92b8-a3e2a444c95c\",\n \"data\": {\n \"a\": 2\n }\n },\n \"links\": [\n {\n \"uri\": \"http://localhost:2113/streams/MyStream/2\",\n \"relation\": \"edit\"\n },\n {\n \"uri\": \"http://localhost:2113/streams/MyStream/2\",\n \"relation\": \"alternate\"\n }\n ]\n}" 103 | in assertEqual "output is equal to expected json" expectedJson buildFeed 104 | 105 | tests :: [TestTree] 106 | tests = [ 107 | testCase "Global Feed XML output check" globalFeedXmlOutputCheck 108 | , testCase "Stream Feed XML output check" streamFeedXmlOutputCheck 109 | , testCase "Event json output check" eventJsonOutputCheck] 110 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/tests/DynamoDbEventStore/GlobalPagingSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module DynamoDbEventStore.GlobalPagingSpec 4 | (tests) 5 | where 6 | 7 | import DynamoDbEventStore.ProjectPrelude 8 | import DynamoDbEventStore.Paging (FeedDirection(..)) 9 | import DynamoDbEventStore.GlobalPaging 10 | import DynamoDbEventStore.PagingSpec(buildRecordedEvent) 11 | import DynamoDbEventStore.Types ( 12 | PageKey(..), 13 | GlobalFeedPosition(..), 14 | StreamId(..), 15 | EventStoreActionError(..), 16 | QueryDirection(..), 17 | EventKey(..), 18 | RecordedEvent(..)) 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | import Control.Lens 22 | import qualified Pipes.Prelude as P 23 | 24 | fibs :: [Int] 25 | fibs = 26 | let acc (a,b) = Just (a + b, (b, a + b)) 27 | in 1 : 1 : unfoldr acc (1, 1) 28 | 29 | groupByFibs :: [a] -> [[a]] 30 | groupByFibs as = 31 | let acc (_,[]) = Nothing 32 | acc ([],_) = error "ran out of fibs that should not happen" 33 | acc (x:xs,ys) = Just (take x ys, (xs, drop x ys)) 34 | in unfoldr acc (fibs, as) 35 | 36 | sampleItems :: Int64 -> [(GlobalFeedPosition, RecordedEvent)] 37 | sampleItems count = 38 | let 39 | items = buildRecordedEvent <$> [0..(count - 1)] 40 | pages = zip [0 ..] (groupByFibs items) 41 | in 42 | join $ buildPositions <$> pages 43 | where 44 | buildPositions :: (Int64, [RecordedEvent]) -> [(GlobalFeedPosition, RecordedEvent)] 45 | buildPositions (page, xs) = 46 | (over _1 (\i -> GlobalFeedPosition (PageKey page) i)) 47 | <$> 48 | zip [0 ..] xs 49 | 50 | sampleGlobalFeedItems :: Monad m => Int64 -> QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, RecordedEvent) m () 51 | sampleGlobalFeedItems count direction startPosition = 52 | let 53 | events QueryDirectionForward Nothing = sampleItems count 54 | events QueryDirectionForward (Just s) = 55 | sampleItems count 56 | & dropWhile (views _1 (< s)) 57 | & tail 58 | events QueryDirectionBackward Nothing = reverse $ sampleItems count 59 | events QueryDirectionBackward (Just s) = 60 | sampleItems count 61 | & reverse 62 | & dropWhile (views _1 (> s)) 63 | in 64 | traverse_ yield $ events direction startPosition 65 | 66 | globalEventsProducer :: Monad m => QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, RecordedEvent) m () 67 | globalEventsProducer = sampleGlobalFeedItems 29 68 | 69 | globalEventKeysProducer :: Monad m => QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, EventKey) m () 70 | globalEventKeysProducer direction startPosition = 71 | sampleGlobalFeedItems 29 direction startPosition 72 | >-> 73 | (P.map (over _2 recordedEventToEventKey)) 74 | where 75 | recordedEventToEventKey RecordedEvent {..} = 76 | EventKey (StreamId recordedEventStreamId, recordedEventNumber) 77 | 78 | getSampleGlobalItems 79 | :: Maybe GlobalFeedPosition 80 | -> Natural 81 | -> FeedDirection 82 | -> Either EventStoreActionError GlobalStreamResult 83 | getSampleGlobalItems startPosition maxItems direction = 84 | let readAllRequest = ReadAllRequest startPosition maxItems direction 85 | in runGlobalStreamRequest globalEventsProducer globalEventKeysProducer readAllRequest 86 | 87 | {- 88 | globalStreamPages: 89 | 0: 0 (1) 90 | 1: 1 (1) 91 | 2: 2,3 (2) 92 | 3: 4,5,6 (3) 93 | 4: 7,8,9,10,11 (5) 94 | 5: 12,13,14,15,16,17,18,19 (8) 95 | 6: 20,21,22,23,24,25,26,27,28,29,30,31,32 (13) 96 | 7: 33..53 (21) 97 | 8: 54..87 (34) 98 | 9: 88,89,90,91,92,93,94,95,96,97,98,99,100.. (55) 99 | -} 100 | globalStreamPagingTests 101 | :: [TestTree] 102 | globalStreamPagingTests = 103 | let getEventTypes start maxItems direction = 104 | fmap2 recordedEventType $ 105 | globalStreamResultEvents <$> 106 | getSampleGlobalItems start maxItems direction 107 | resultAssert testName start maxItems direction expectedBodies = 108 | testCase testName $ 109 | assertEqual 110 | "Should return events" 111 | (Right expectedBodies) 112 | (getEventTypes start maxItems direction) 113 | in [ resultAssert 114 | "Start of feed forward - start = Nothing" 115 | Nothing 116 | 1 117 | FeedDirectionForward 118 | ["0"] 119 | , resultAssert 120 | "0 0 of feed forward" 121 | (Just $ GlobalFeedPosition 0 0) 122 | 1 123 | FeedDirectionForward 124 | ["1"] 125 | , resultAssert 126 | "Middle of the feed forward" 127 | (Just $ GlobalFeedPosition 1 0) 128 | 3 129 | FeedDirectionForward 130 | ["2", "3", "4"] 131 | , resultAssert 132 | "End of the feed forward" 133 | (Just $ GlobalFeedPosition 6 7) 134 | 3 135 | FeedDirectionForward 136 | ["28"] 137 | , resultAssert 138 | "End of feed backward - start = Nothing" 139 | Nothing 140 | 3 141 | FeedDirectionBackward 142 | ["28", "27", "26"] 143 | , resultAssert 144 | "End of the feed backward" 145 | (Just $ GlobalFeedPosition 6 8) 146 | 3 147 | FeedDirectionBackward 148 | ["28", "27", "26"] 149 | , resultAssert 150 | "Middle of the feed backward" 151 | (Just $ GlobalFeedPosition 5 7) 152 | 3 153 | FeedDirectionBackward 154 | ["19", "18", "17"] 155 | , resultAssert 156 | "End of feed backward" 157 | (Just $ GlobalFeedPosition 0 0) 158 | 1 159 | FeedDirectionBackward 160 | ["0"]] 161 | 162 | globalStreamLinkTests :: [TestTree] 163 | globalStreamLinkTests = 164 | let toFeedPosition page offset = 165 | Just 166 | GlobalFeedPosition 167 | { globalFeedPositionPage = page 168 | , globalFeedPositionOffset = offset 169 | } 170 | endOfFeedBackward = 171 | ( "End of feed backward" 172 | , getSampleGlobalItems Nothing 20 FeedDirectionBackward) 173 | middleOfFeedBackward = 174 | ( "Middle of feed backward" 175 | , getSampleGlobalItems 176 | (toFeedPosition 6 5) 177 | 20 178 | FeedDirectionBackward) 179 | startOfFeedBackward = 180 | ( "Start of feed backward" 181 | , getSampleGlobalItems 182 | (toFeedPosition 1 0) 183 | 20 184 | FeedDirectionBackward) 185 | startOfFeedForward = 186 | ( "Start of feed forward" 187 | , getSampleGlobalItems Nothing 20 FeedDirectionForward) 188 | middleOfFeedForward = 189 | ( "Middle of feed forward" 190 | , getSampleGlobalItems (toFeedPosition 2 1) 20 FeedDirectionForward) 191 | endOfFeedForward = 192 | ( "End of feed forward" 193 | , getSampleGlobalItems (toFeedPosition 6 8) 20 FeedDirectionForward) 194 | streamResultLast' = ("last", globalStreamResultLast) 195 | streamResultFirst' = ("first", globalStreamResultFirst) 196 | streamResultNext' = ("next", globalStreamResultNext) 197 | streamResultPrevious' = ("previous", globalStreamResultPrevious) 198 | toStartPosition page offset = 199 | GlobalStartPosition $ GlobalFeedPosition page offset 200 | linkAssert (feedResultName,feedResult) (linkName,streamLink) expectedResult = 201 | testCase 202 | ("Unit - " <> feedResultName <> " - " <> linkName <> " link") $ 203 | assertEqual 204 | ("Should have " <> linkName <> " link") 205 | (Right expectedResult) 206 | (fmap streamLink feedResult) 207 | in [ linkAssert 208 | endOfFeedBackward 209 | streamResultFirst' 210 | (Just (FeedDirectionBackward, GlobalStartHead, 20)) 211 | , linkAssert 212 | endOfFeedBackward 213 | streamResultLast' 214 | (Just (FeedDirectionForward, GlobalStartHead, 20)) 215 | , linkAssert 216 | endOfFeedBackward 217 | streamResultNext' 218 | (Just (FeedDirectionBackward, toStartPosition 4 1, 20)) 219 | , linkAssert 220 | endOfFeedBackward 221 | streamResultPrevious' 222 | (Just (FeedDirectionForward, toStartPosition 6 8, 20)) 223 | , linkAssert 224 | middleOfFeedBackward 225 | streamResultFirst' 226 | (Just (FeedDirectionBackward, GlobalStartHead, 20)) 227 | , linkAssert 228 | middleOfFeedBackward 229 | streamResultLast' 230 | (Just (FeedDirectionForward, GlobalStartHead, 20)) 231 | , linkAssert 232 | middleOfFeedBackward 233 | streamResultNext' 234 | (Just (FeedDirectionBackward, toStartPosition 3 1, 20)) 235 | , linkAssert 236 | middleOfFeedBackward 237 | streamResultPrevious' 238 | (Just (FeedDirectionForward, toStartPosition 6 5, 20)) 239 | , linkAssert 240 | startOfFeedBackward 241 | streamResultFirst' 242 | (Just (FeedDirectionBackward, GlobalStartHead, 20)) 243 | , linkAssert startOfFeedBackward streamResultLast' Nothing 244 | , linkAssert startOfFeedBackward streamResultNext' Nothing 245 | , linkAssert 246 | startOfFeedBackward 247 | streamResultPrevious' 248 | (Just (FeedDirectionForward, toStartPosition 1 0, 20)) 249 | , linkAssert 250 | startOfFeedForward 251 | streamResultFirst' 252 | (Just (FeedDirectionBackward, GlobalStartHead, 20)) 253 | , linkAssert startOfFeedForward streamResultLast' Nothing 254 | , linkAssert startOfFeedForward streamResultNext' Nothing 255 | , linkAssert 256 | startOfFeedForward 257 | streamResultPrevious' 258 | (Just (FeedDirectionForward, toStartPosition 5 7, 20)) 259 | , linkAssert 260 | middleOfFeedForward 261 | streamResultFirst' 262 | (Just (FeedDirectionBackward, GlobalStartHead, 20)) 263 | , linkAssert 264 | middleOfFeedForward 265 | streamResultLast' 266 | (Just (FeedDirectionForward, GlobalStartHead, 20)) 267 | , linkAssert 268 | middleOfFeedForward 269 | streamResultNext' 270 | (Just (FeedDirectionBackward, toStartPosition 2 1, 20)) 271 | , linkAssert 272 | middleOfFeedForward 273 | streamResultPrevious' 274 | (Just (FeedDirectionForward, toStartPosition 6 3, 20)) 275 | , linkAssert 276 | endOfFeedForward 277 | streamResultFirst' 278 | (Just (FeedDirectionBackward, GlobalStartHead, 20)) 279 | , linkAssert 280 | endOfFeedForward 281 | streamResultLast' 282 | (Just (FeedDirectionForward, GlobalStartHead, 20)) 283 | , linkAssert 284 | endOfFeedForward 285 | streamResultNext' 286 | (Just (FeedDirectionBackward, toStartPosition 6 8, 20)) 287 | , linkAssert endOfFeedForward streamResultPrevious' Nothing] 288 | 289 | tests :: [TestTree] 290 | tests = [ 291 | testGroup "Global Stream Paging Tests" globalStreamPagingTests 292 | , testGroup "Global Stream Link Tests" globalStreamLinkTests 293 | ] 294 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/tests/DynamoDbEventStore/PagingSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module DynamoDbEventStore.PagingSpec 3 | (tests,buildRecordedEvent) 4 | where 5 | 6 | import DynamoDbEventStore.ProjectPrelude 7 | import Data.Maybe (fromJust) 8 | import DynamoDbEventStore.Paging 9 | import DynamoDbEventStore.Types (EventStoreActionError,RecordedEvent(..),EventId,StreamId(..),EventId(..),QueryDirection(..)) 10 | import Test.Tasty 11 | import qualified Data.Text.Encoding as T 12 | import Test.Tasty.HUnit 13 | import Data.Time 14 | import qualified Data.UUID as UUID 15 | 16 | testStreamId :: Text 17 | testStreamId = "MyStream" 18 | 19 | sampleTime :: UTCTime 20 | sampleTime = 21 | parseTimeOrError 22 | True 23 | defaultTimeLocale 24 | rfc822DateFormat 25 | "Sun, 08 May 2016 12:49:41 +0000" 26 | 27 | eventIdFromString :: String -> EventId 28 | eventIdFromString = EventId . fromJust . UUID.fromString 29 | 30 | sampleEventId :: EventId 31 | sampleEventId = eventIdFromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c" 32 | 33 | buildRecordedEvent :: Int64 -> RecordedEvent 34 | buildRecordedEvent index = 35 | RecordedEvent { 36 | recordedEventStreamId = testStreamId 37 | , recordedEventNumber = index 38 | , recordedEventType = tshow index 39 | , recordedEventData = T.encodeUtf8 "Some data" 40 | , recordedEventCreated = sampleTime 41 | , recordedEventId = sampleEventId 42 | , recordedEventIsJson = False } 43 | sampleItems :: Monad m => Int64 -> QueryDirection -> Maybe Int64 -> Producer RecordedEvent m () 44 | sampleItems count direction startEvent = 45 | let 46 | maxEventNumber = count - 1 47 | eventNumbers QueryDirectionForward Nothing = [0..maxEventNumber] 48 | eventNumbers QueryDirectionForward (Just s) = [s..maxEventNumber] 49 | eventNumbers QueryDirectionBackward Nothing = [maxEventNumber,(maxEventNumber-1)..0] 50 | eventNumbers QueryDirectionBackward (Just s) = [s,(s - 1)..0] 51 | in traverse_ (yield . buildRecordedEvent) (eventNumbers direction startEvent) 52 | 53 | streamEventsProducer :: (Monad m) => QueryDirection -> StreamId -> Maybe Int64 -> Natural -> Producer RecordedEvent m () 54 | streamEventsProducer direction _streamId startEvent _batchSize = 55 | sampleItems 29 direction startEvent 56 | 57 | getSampleItems 58 | :: Maybe Int64 59 | -> Natural 60 | -> FeedDirection 61 | -> Either EventStoreActionError (Maybe StreamResult) 62 | getSampleItems startEvent maxItems direction = 63 | let request = ReadStreamRequest { 64 | rsrStreamId = StreamId testStreamId, 65 | rsrStartEventNumber = startEvent, 66 | rsrMaxItems = maxItems, 67 | rsrDirection = direction 68 | } 69 | in runStreamRequest streamEventsProducer request 70 | 71 | streamLinkTests :: [TestTree] 72 | streamLinkTests = 73 | let endOfFeedBackward = 74 | ( "End of feed backward" 75 | , getSampleItems Nothing 20 FeedDirectionBackward) 76 | middleOfFeedBackward = 77 | ( "Middle of feed backward" 78 | , getSampleItems (Just 26) 20 FeedDirectionBackward) 79 | startOfFeedBackward = 80 | ( "Start of feed backward" 81 | , getSampleItems (Just 1) 20 FeedDirectionBackward) 82 | pastEndOfFeedBackward = 83 | ( "Past end of feed backward" 84 | , getSampleItems (Just 100) 20 FeedDirectionBackward) 85 | startOfFeedForward = 86 | ( "Start of feed forward" 87 | , getSampleItems Nothing 20 FeedDirectionForward) 88 | middleOfFeedForward = 89 | ( "Middle of feed forward" 90 | , getSampleItems (Just 3) 20 FeedDirectionForward) 91 | endOfFeedForward = 92 | ( "End of feed forward" 93 | , getSampleItems (Just 20) 20 FeedDirectionForward) 94 | pastEndOfFeedForward = 95 | ( "Past end of feed forward" 96 | , getSampleItems (Just 100) 20 FeedDirectionForward) 97 | streamResultLast' = ("last", streamResultLast) 98 | streamResultFirst' = ("first", streamResultFirst) 99 | streamResultNext' = ("next", streamResultNext) 100 | streamResultPrevious' = ("previous", streamResultPrevious) 101 | linkAssert (feedResultName,feedResult) (linkName,streamLink) expectedResult = 102 | testCase 103 | ("Unit - " <> feedResultName <> " - " <> linkName <> " link") $ 104 | assertEqual 105 | ("Should have " <> linkName <> " link") 106 | (Right (Just expectedResult)) 107 | (fmap2 streamLink feedResult) 108 | in [ linkAssert 109 | endOfFeedBackward 110 | streamResultFirst' 111 | (Just (FeedDirectionBackward, EventStartHead, 20)) 112 | , linkAssert 113 | endOfFeedBackward 114 | streamResultLast' 115 | (Just (FeedDirectionForward, EventStartPosition 0, 20)) 116 | , linkAssert 117 | endOfFeedBackward 118 | streamResultNext' 119 | (Just (FeedDirectionBackward, EventStartPosition 8, 20)) 120 | , linkAssert 121 | endOfFeedBackward 122 | streamResultPrevious' 123 | (Just (FeedDirectionForward, EventStartPosition 29, 20)) 124 | , linkAssert 125 | middleOfFeedBackward 126 | streamResultFirst' 127 | (Just (FeedDirectionBackward, EventStartHead, 20)) 128 | , linkAssert 129 | middleOfFeedBackward 130 | streamResultLast' 131 | (Just (FeedDirectionForward, EventStartPosition 0, 20)) 132 | , linkAssert 133 | middleOfFeedBackward 134 | streamResultNext' 135 | (Just (FeedDirectionBackward, EventStartPosition 6, 20)) 136 | , linkAssert 137 | middleOfFeedBackward 138 | streamResultPrevious' 139 | (Just (FeedDirectionForward, EventStartPosition 27, 20)) 140 | , linkAssert 141 | startOfFeedBackward 142 | streamResultFirst' 143 | (Just (FeedDirectionBackward, EventStartHead, 20)) 144 | , linkAssert startOfFeedBackward streamResultLast' Nothing 145 | , linkAssert startOfFeedBackward streamResultNext' Nothing 146 | , linkAssert 147 | startOfFeedBackward 148 | streamResultPrevious' 149 | (Just (FeedDirectionForward, EventStartPosition 2, 20)) 150 | , linkAssert 151 | pastEndOfFeedBackward 152 | streamResultFirst' 153 | (Just (FeedDirectionBackward, EventStartHead, 20)) 154 | , linkAssert 155 | pastEndOfFeedBackward 156 | streamResultLast' 157 | (Just (FeedDirectionForward, EventStartPosition 0, 20)) 158 | , linkAssert 159 | pastEndOfFeedBackward 160 | streamResultNext' 161 | (Just (FeedDirectionBackward, EventStartPosition 80, 20)) 162 | , linkAssert 163 | pastEndOfFeedBackward 164 | streamResultPrevious' 165 | (Just (FeedDirectionForward, EventStartPosition 29, 20)) 166 | , linkAssert 167 | startOfFeedForward 168 | streamResultFirst' 169 | (Just (FeedDirectionBackward, EventStartHead, 20)) 170 | , linkAssert startOfFeedForward streamResultLast' Nothing 171 | , linkAssert startOfFeedForward streamResultNext' Nothing 172 | , linkAssert 173 | startOfFeedForward 174 | streamResultPrevious' 175 | (Just (FeedDirectionForward, EventStartPosition 20, 20)) 176 | , linkAssert 177 | middleOfFeedForward 178 | streamResultFirst' 179 | (Just (FeedDirectionBackward, EventStartHead, 20)) 180 | , linkAssert 181 | middleOfFeedForward 182 | streamResultLast' 183 | (Just (FeedDirectionForward, EventStartPosition 0, 20)) 184 | , linkAssert 185 | middleOfFeedForward 186 | streamResultNext' 187 | (Just (FeedDirectionBackward, EventStartPosition 2, 20)) 188 | , linkAssert 189 | middleOfFeedForward 190 | streamResultPrevious' 191 | (Just (FeedDirectionForward, EventStartPosition 23, 20)) 192 | , linkAssert 193 | endOfFeedForward 194 | streamResultFirst' 195 | (Just (FeedDirectionBackward, EventStartHead, 20)) 196 | , linkAssert 197 | endOfFeedForward 198 | streamResultLast' 199 | (Just (FeedDirectionForward, EventStartPosition 0, 20)) 200 | , linkAssert 201 | endOfFeedForward 202 | streamResultNext' 203 | (Just (FeedDirectionBackward, EventStartPosition 19, 20)) 204 | , linkAssert 205 | endOfFeedForward 206 | streamResultPrevious' 207 | (Just (FeedDirectionForward, EventStartPosition 29, 20)) 208 | , linkAssert 209 | pastEndOfFeedForward 210 | streamResultFirst' 211 | (Just (FeedDirectionBackward, EventStartHead, 20)) 212 | , linkAssert 213 | pastEndOfFeedForward 214 | streamResultLast' 215 | (Just (FeedDirectionForward, EventStartPosition 0, 20)) 216 | , linkAssert 217 | pastEndOfFeedForward 218 | streamResultNext' 219 | (Just (FeedDirectionBackward, EventStartPosition 99, 20)) 220 | , linkAssert pastEndOfFeedForward streamResultPrevious' Nothing] 221 | 222 | {- 223 | readStreamProgram :: Text 224 | -> Natural 225 | -> FeedDirection 226 | -> DynamoCmdM Queue [Int64] 227 | readStreamProgram streamId pageSize direction = 228 | let streamResultLink = 229 | case direction of 230 | FeedDirectionBackward -> streamResultNext 231 | FeedDirectionForward -> streamResultPrevious 232 | request startEventNumber = 233 | ReadStreamRequest 234 | { rsrStreamId = StreamId streamId 235 | , rsrMaxItems = pageSize 236 | , rsrStartEventNumber = startEventNumber 237 | , rsrDirection = direction 238 | } 239 | positionToRequest EventStartHead = request Nothing 240 | positionToRequest (EventStartPosition p) = request $ Just p 241 | getResultEventNumbers :: StreamResult -> ([Int64], Maybe StreamOffset) 242 | getResultEventNumbers streamResult@StreamResult{..} = 243 | ( recordedEventNumber <$> streamResultEvents 244 | , streamResultLink streamResult) 245 | start :: Maybe StreamOffset 246 | start = Just $ (FeedDirectionBackward, EventStartHead, pageSize) 247 | acc 248 | :: Maybe StreamOffset 249 | -> DynamoCmdM Queue (Maybe ([Int64], Maybe StreamOffset)) 250 | acc Nothing = return Nothing 251 | acc (Just (_,position,_)) = 252 | either (const Nothing) (fmap getResultEventNumbers) <$> 253 | getReadStreamRequestProgram (positionToRequest position) 254 | in join <$> unfoldrM acc start 255 | 256 | prop_all_items_are_in_stream_when_paged_through :: QC.Positive Natural 257 | -> QC.Positive Int 258 | -> FeedDirection 259 | -> QC.Property 260 | prop_all_items_are_in_stream_when_paged_through (QC.Positive pageSize) (QC.Positive streamLength) direction = 261 | let startState = pagedTestStateItems streamLength 262 | program = readStreamProgram "MyStream" pageSize direction 263 | programResult = evalProgram "readStream" program startState 264 | maxEventNumber = fromIntegral $ streamLength - 1 265 | expectedResult = 266 | case direction of 267 | FeedDirectionForward -> [0 .. maxEventNumber] 268 | FeedDirectionBackward -> 269 | [maxEventNumber,maxEventNumber - 1 .. 0] 270 | in programResult === expectedResult 271 | -} 272 | 273 | tests :: [TestTree] 274 | tests = [ 275 | testGroup "Single Stream Link Tests" streamLinkTests 276 | --, testProperty 277 | -- "All items are in the stream when paged through" 278 | -- prop_all_items_are_in_stream_when_paged_through 279 | ] 280 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/tests/WebserverInternalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module WebserverInternalSpec (spec) where 3 | 4 | 5 | import BasicPrelude 6 | import qualified Data.Text.Lazy as TL 7 | import qualified DynamoDbEventStore.Webserver as W 8 | import Test.Tasty.Hspec 9 | import Test.Tasty.QuickCheck 10 | import Text.Read (readMaybe) 11 | 12 | showText :: Show a => a -> LText 13 | showText = TL.fromStrict . tshow 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "parseInt64" $ do 18 | let run = W.runParser W.positiveInt64Parser () 19 | 20 | it "can parse any positive int64" $ property $ 21 | \x -> x >= 0 ==> run (showText (x :: Int64)) === Right x 22 | 23 | it "will not parse negative numbers" $ property $ 24 | \x -> x < 0 ==> run (showText (x :: Int64)) === Left () 25 | 26 | it "will not parse anything that read cannot convert read" $ property $ 27 | \x -> (Text.Read.readMaybe x :: Maybe Int64) == Nothing ==> run (showText x) === Left () 28 | 29 | it "will not parse numbers that are too large" $ do 30 | let tooLarge = toInteger (maxBound :: Int64) + 1 31 | run (showText tooLarge) == Left () 32 | describe "global feed position" $ do 33 | it "can round trip any position" $ property $ 34 | \position -> W.parseGlobalFeedPosition(W.globalFeedPositionToText(position)) === Just position 35 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/tests/WebserverSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module WebserverSpec (postEventSpec, getStreamSpec, getEventSpec) where 4 | 5 | import BasicPrelude 6 | import Control.Monad.Reader 7 | import qualified Data.Text.Lazy as TL 8 | import Data.Time.Clock 9 | import Data.Time.Format 10 | import DynamoDbEventStore.EventStoreActions (EventStoreAction) 11 | import qualified DynamoDbEventStore.Webserver as W 12 | import qualified Network.HTTP.Types as H 13 | import Network.Wai 14 | import Network.Wai.Test 15 | import Test.Tasty.Hspec 16 | import qualified Web.Scotty.Trans as S 17 | 18 | addEventPost :: [H.Header] -> Session SResponse 19 | addEventPost headers = 20 | request $ defaultRequest { 21 | pathInfo = ["streams","streamId"], 22 | requestMethod = H.methodPost, 23 | requestHeaders = headers, 24 | requestBody = pure "" } 25 | 26 | evHeader :: H.HeaderName 27 | evHeader = "ES-ExpectedVersion" 28 | etHeader :: H.HeaderName 29 | etHeader = "ES-EventType" 30 | eventIdHeader :: H.HeaderName 31 | eventIdHeader = "ES-EventId" 32 | 33 | showEventResponse :: (Monad m, S.ScottyError e) => EventStoreAction -> S.ActionT e m () 34 | showEventResponse eventStoreAction = S.text $ TL.fromStrict $ tshow eventStoreAction 35 | 36 | app :: IO Application 37 | app = do 38 | sampleTime <- parseTimeM True defaultTimeLocale rfc822DateFormat "Sun, 08 May 2016 12:49:41 +0000" 39 | S.scottyAppT (`runReaderT` sampleTime) (W.app showEventResponse :: S.ScottyT LText (ReaderT UTCTime IO) ()) 40 | 41 | postEventSpec :: Spec 42 | postEventSpec = do 43 | let baseHeaders = [ 44 | (etHeader, "MyEventType"), 45 | (eventIdHeader, "12f44004-f5dd-41f1-8225-72dd65a0332e"), 46 | ("Content-Type", "application/json")] 47 | let requestWithExpectedVersion = addEventPost $ (evHeader, "1"):baseHeaders 48 | let requestWithoutExpectedVersion = addEventPost baseHeaders 49 | let requestWithoutBadExpectedVersion = addEventPost $ (evHeader, "NotAnInt"):baseHeaders 50 | let requestWithoutEventType = addEventPost [(evHeader, "1")] 51 | 52 | describe "Parse Int64 header" $ do 53 | it "responds with 200" $ 54 | waiCase requestWithExpectedVersion $ assertStatus 200 55 | 56 | it "responds with body" $ 57 | waiCase requestWithExpectedVersion $ assertBody "PostEvent (PostEventRequest {perStreamId = \"streamId\", perExpectedVersion = Just 1, perEvents = EventEntry {eventEntryData = \"\", eventEntryType = EventType \"MyEventType\", eventEntryEventId = EventId {unEventId = 12f44004-f5dd-41f1-8225-72dd65a0332e}, eventEntryCreated = EventTime 2016-05-08 12:49:41 UTC, eventEntryIsJson = True} :| []})" 58 | 59 | describe "POST /streams/streamId without ExepectedVersion" $ do 60 | it "responds with 200" $ 61 | waiCase requestWithoutExpectedVersion $ assertStatus 200 62 | 63 | it "responds with body" $ 64 | waiCase requestWithoutExpectedVersion $ assertBody "PostEvent (PostEventRequest {perStreamId = \"streamId\", perExpectedVersion = Nothing, perEvents = EventEntry {eventEntryData = \"\", eventEntryType = EventType \"MyEventType\", eventEntryEventId = EventId {unEventId = 12f44004-f5dd-41f1-8225-72dd65a0332e}, eventEntryCreated = EventTime 2016-05-08 12:49:41 UTC, eventEntryIsJson = True} :| []})" 65 | 66 | describe "POST /streams/streamId without EventType" $ 67 | it "responds with 400" $ 68 | waiCase requestWithoutEventType $ assertStatus 400 69 | 70 | describe "POST /streams/streamId without ExepectedVersion greater than Int64.max" $ 71 | it "responds with 400" $ 72 | addEventPost [("ES-ExpectedVersion", "9223372036854775808")] `waiCase` assertStatus 400 73 | 74 | describe "POST /streams/streamId with non-integer ExpectedVersion" $ 75 | it "responds with 400" $ 76 | requestWithoutBadExpectedVersion `waiCase` assertStatus 400 77 | 78 | getStream :: Text -> Session SResponse 79 | getStream streamId = 80 | request $ defaultRequest { 81 | pathInfo = ["streams",streamId], 82 | requestMethod = H.methodGet 83 | } 84 | 85 | assertSuccess :: String -> [Text] -> LByteString -> Spec 86 | assertSuccess desc path expectedType = 87 | describe ("Get " <> desc) $ do 88 | let getExample = request $ defaultRequest { 89 | pathInfo = path, 90 | requestMethod = H.methodGet 91 | } 92 | 93 | it "responds with 200" $ 94 | waiCase getExample $ assertStatus 200 95 | 96 | it "responds with body" $ 97 | waiCase getExample $ assertBody expectedType 98 | 99 | getStreamSpec :: Spec 100 | getStreamSpec = do 101 | assertSuccess 102 | "stream simple" 103 | ["streams","myStreamId"] 104 | "ReadStream (ReadStreamRequest {rsrStreamId = StreamId {unStreamId = \"myStreamId\"}, rsrStartEventNumber = Nothing, rsrMaxItems = 20, rsrDirection = FeedDirectionBackward})" 105 | 106 | assertSuccess 107 | "stream $all simple" 108 | ["streams","%24all"] 109 | "ReadAll (ReadAllRequest {readAllRequestStartPosition = Nothing, readAllRequestMaxItems = 20, readAllRequestDirection = FeedDirectionBackward})" 110 | 111 | assertSuccess 112 | "stream with start event and limit" 113 | ["streams","myStreamId","3","5"] 114 | "ReadStream (ReadStreamRequest {rsrStreamId = StreamId {unStreamId = \"myStreamId\"}, rsrStartEventNumber = Just 3, rsrMaxItems = 5, rsrDirection = FeedDirectionBackward})" 115 | 116 | assertSuccess 117 | "stream $all with start event and limit" 118 | ["streams","%24all","3-2","5"] 119 | "ReadAll (ReadAllRequest {readAllRequestStartPosition = Just (GlobalFeedPosition {globalFeedPositionPage = 3, globalFeedPositionOffset = 2}), readAllRequestMaxItems = 5, readAllRequestDirection = FeedDirectionBackward})" 120 | 121 | assertSuccess 122 | "stream with start and limit, backward" 123 | ["streams","myStreamId","3","backward","5"] 124 | "ReadStream (ReadStreamRequest {rsrStreamId = StreamId {unStreamId = \"myStreamId\"}, rsrStartEventNumber = Just 3, rsrMaxItems = 5, rsrDirection = FeedDirectionBackward})" 125 | 126 | assertSuccess 127 | "stream $all with start and limit, backward" 128 | ["streams","%24all","3-2","backward","5"] 129 | "ReadAll (ReadAllRequest {readAllRequestStartPosition = Just (GlobalFeedPosition {globalFeedPositionPage = 3, globalFeedPositionOffset = 2}), readAllRequestMaxItems = 5, readAllRequestDirection = FeedDirectionBackward})" 130 | 131 | assertSuccess 132 | "stream backward from head" 133 | ["streams","myStreamId","head","backward","5"] 134 | "ReadStream (ReadStreamRequest {rsrStreamId = StreamId {unStreamId = \"myStreamId\"}, rsrStartEventNumber = Nothing, rsrMaxItems = 5, rsrDirection = FeedDirectionBackward})" 135 | 136 | assertSuccess 137 | "stream $all backward from head" 138 | ["streams","%24all","head","backward","5"] 139 | "ReadAll (ReadAllRequest {readAllRequestStartPosition = Nothing, readAllRequestMaxItems = 5, readAllRequestDirection = FeedDirectionBackward})" 140 | 141 | assertSuccess 142 | "stream with start and limit, forward" 143 | ["streams","myStreamId","3","forward","5"] 144 | "ReadStream (ReadStreamRequest {rsrStreamId = StreamId {unStreamId = \"myStreamId\"}, rsrStartEventNumber = Just 3, rsrMaxItems = 5, rsrDirection = FeedDirectionForward})" 145 | 146 | assertSuccess 147 | "stream $all with start and limit, forward" 148 | ["streams","%24all","3-2","forward","5"] 149 | "ReadAll (ReadAllRequest {readAllRequestStartPosition = Just (GlobalFeedPosition {globalFeedPositionPage = 3, globalFeedPositionOffset = 2}), readAllRequestMaxItems = 5, readAllRequestDirection = FeedDirectionForward})" 150 | 151 | describe "Get stream with missing stream name" $ do 152 | let getExample = getStream "" 153 | it "responds with 400" $ 154 | waiCase getExample $ assertStatus 400 155 | 156 | getEvent :: Text -> Int64 -> Session SResponse 157 | getEvent streamId eventNumber = 158 | request $ defaultRequest { 159 | pathInfo = ["streams",streamId,tshow eventNumber], 160 | requestMethod = H.methodGet 161 | } 162 | 163 | getEventSpec :: Spec 164 | getEventSpec = 165 | describe "Get stream" $ do 166 | let getExample = getEvent "myStreamId" 0 167 | it "responds with 200" $ 168 | waiCase getExample $ assertStatus 200 169 | 170 | it "responds with body" $ 171 | waiCase getExample $ assertBody "ReadEvent (ReadEventRequest {rerStreamId = \"myStreamId\", rerEventNumber = 0})" 172 | 173 | waiCase :: Session SResponse -> (SResponse -> Session ()) -> IO () 174 | waiCase r assertion = do 175 | app' <- app 176 | flip runSession app' $ assertion =<< r 177 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/tests/tastytests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import BasicPrelude 6 | import DynamoDbEventStore.FeedOutputSpec as FeedOutputSpec 7 | 8 | import Test.Tasty 9 | import Test.Tasty.Hspec 10 | import qualified WebserverInternalSpec 11 | import WebserverSpec 12 | import qualified DynamoDbEventStore.PagingSpec as PagingSpec 13 | import qualified DynamoDbEventStore.GlobalPagingSpec as GlobalPagingSpec 14 | 15 | 16 | main :: IO () 17 | main = do 18 | postEventSpec' <- testSpec "Post Event tests" postEventSpec 19 | getStreamSpec' <- testSpec "Get Stream tests" getStreamSpec 20 | getEventSpec' <- testSpec "Get Event tests" getEventSpec 21 | webserverInternalTests' <- testSpec "Webserver Internal Tests" WebserverInternalSpec.spec 22 | defaultMain $ 23 | testGroup "Tests" 24 | [ testGroup "Feed Output" FeedOutputSpec.tests, 25 | postEventSpec', 26 | getStreamSpec', 27 | getEventSpec', 28 | webserverInternalTests', 29 | testGroup "Paging tests" PagingSpec.tests, 30 | testGroup "Global Paging tests" GlobalPagingSpec.tests 31 | ] 32 | -------------------------------------------------------------------------------- /dynamodb-eventstore-web/web/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Main where 7 | 8 | import BasicPrelude 9 | import Control.Concurrent 10 | import Control.Monad.Except 11 | import Control.Monad.Trans.AWS 12 | import qualified Data.Text as T 13 | import DynamoDbEventStore 14 | import DynamoDbEventStore.EventStoreActions 15 | import DynamoDbEventStore.Webserver 16 | (EventStoreActionRunner(..), app, realRunner) 17 | import Network.Wai.Handler.Warp 18 | import Options.Applicative as Opt 19 | import System.Exit 20 | import System.Metrics hiding (Value) 21 | import qualified System.Metrics.Counter as Counter 22 | import qualified System.Metrics.Distribution as Distribution 23 | import System.Remote.Monitoring 24 | import Network.AWS.DynamoDB 25 | import Web.Scotty 26 | 27 | printEvent 28 | :: (MonadIO m) 29 | => EventStoreAction -> m EventStoreAction 30 | printEvent a = do 31 | liftIO $ print . tshow $ a 32 | return a 33 | 34 | buildActionRunner :: 35 | (forall a. EventStore a -> IO (Either EventStoreError a)) 36 | -> EventStoreActionRunner 37 | buildActionRunner runner = 38 | EventStoreActionRunner 39 | { eventStoreActionRunnerPostEvent = (\req -> 40 | PostEventResult <$> (runner $ postEventRequestProgram req)) 41 | , eventStoreActionRunnerReadEvent = (\req -> 42 | ReadEventResult <$> (runner $ getReadEventRequestProgram req)) 43 | , eventStoreActionRunnerReadStream = (\req -> 44 | ReadStreamResult <$> (runner $ getReadStreamRequestProgram req)) 45 | , eventStoreActionRunnerReadAll = (\req -> 46 | ReadAllResult <$> (runner $ getReadAllRequestProgram req)) 47 | } 48 | 49 | data Config = Config 50 | { configTableName :: String 51 | , configPort :: Int 52 | , configLocalDynamoDB :: Bool 53 | , configCreateTable :: Bool 54 | } 55 | 56 | config :: Parser Config 57 | config = 58 | Config <$> 59 | strOption 60 | (long "tableName" <> metavar "TABLENAME" <> help "DynamoDB table name") <*> 61 | option 62 | auto 63 | (long "port" <> value 2113 <> short 'p' <> metavar "PORT" <> 64 | help "HTTP port") <*> 65 | flag False True (long "dynamoLocal" <> help "Use dynamodb local") <*> 66 | flag 67 | False 68 | True 69 | (long "createTable" <> short 'c' <> 70 | help "Create table if it does not exist") 71 | 72 | httpHost :: String 73 | httpHost = "127.0.0.1" 74 | 75 | toExceptT' :: IO (Either e a) -> ExceptT e (IO) a 76 | toExceptT' p = do 77 | a <- lift p 78 | case a of 79 | Left s -> throwError $ s 80 | Right r -> return r 81 | 82 | toApplicationError 83 | :: forall a. 84 | (EventStore a -> IO (Either EventStoreError a)) 85 | -> (EventStore a -> ExceptT EventStoreError IO a) 86 | toApplicationError runner a = do 87 | result <- liftIO $ runner a 88 | case result of 89 | Left s -> throwError s 90 | Right r -> return r 91 | 92 | data ApplicationError 93 | = ApplicationErrorInterpreter InterpreterError 94 | | ApplicationErrorGlobalFeedWriter EventStoreActionError 95 | deriving ((Show)) 96 | 97 | forkAndSupervise :: Text -> IO () -> IO () 98 | forkAndSupervise processName = void . forkIO . handle onError 99 | where 100 | onError :: SomeException -> IO () 101 | onError e = do 102 | putStrLn $ "Exception in " <> processName 103 | putStrLn . T.pack $ displayException e 104 | threadDelay 10000000 -- 10 seconds 105 | 106 | printError 107 | :: (Show a) 108 | => a -> IO () 109 | printError err = putStrLn $ "Error: " <> tshow err 110 | 111 | forkGlobalFeedWriter :: (forall a. EventStore a -> IO (Either EventStoreError a)) 112 | -> IO () 113 | forkGlobalFeedWriter runner = 114 | forkAndSupervise "GlobalFeedWriter" $ do 115 | result <- runner runGlobalFeedWriter 116 | case result of 117 | (Left err) -> printError err 118 | (Right _) -> return () 119 | 120 | startWebServer :: 121 | (forall a. EventStore a -> IO (Either EventStoreError a)) 122 | -> Config 123 | -> IO () 124 | startWebServer runner parsedConfig = do 125 | let httpPort = configPort parsedConfig 126 | let warpSettings = 127 | setPort httpPort $ setHost (fromString httpHost) defaultSettings 128 | let baseUri = "http://" <> fromString httpHost <> ":" <> tshow httpPort 129 | putStrLn $ "Server listenting on: " <> baseUri 130 | void $ 131 | scottyApp 132 | (app (printEvent >=> realRunner baseUri (buildActionRunner runner))) >>= 133 | runSettings warpSettings 134 | 135 | startMetrics :: IO MetricLogs 136 | startMetrics = do 137 | metricServer <- forkServer "localhost" 8001 138 | let store = serverMetricStore metricServer 139 | readItemPair <- createPair store "readItem" 140 | writeItemPair <- createPair store "writeItem" 141 | updateItemPair <- createPair store "updateItem" 142 | queryPair <- createPair store "query" 143 | scanPair <- createPair store "scan" 144 | return 145 | MetricLogs 146 | { metricLogsReadItem = readItemPair 147 | , metricLogsWriteItem = writeItemPair 148 | , metricLogsUpdateItem = updateItemPair 149 | , metricLogsQuery = queryPair 150 | , metricLogsScan = scanPair 151 | , metricLogsStore = store 152 | } 153 | where 154 | createPair store name = do 155 | theCounter <- createCounter ("dynamodb-eventstore." <> name) store 156 | theDistribution <- 157 | createDistribution ("dynamodb-eventstore." <> name <> "_ms") store 158 | return $ 159 | MetricLogsPair 160 | (Counter.inc theCounter) 161 | (Distribution.add theDistribution) 162 | 163 | runDynamoCloud' :: RuntimeEnvironment 164 | -> EventStore a 165 | -> IO (Either EventStoreError a) 166 | runDynamoCloud' runtimeEnvironment x = 167 | runResourceT $ runAWST runtimeEnvironment $ runExceptT $ x 168 | 169 | runDynamoLocal' :: RuntimeEnvironment 170 | -> EventStore a 171 | -> IO (Either EventStoreError a) 172 | runDynamoLocal' env x = do 173 | let dynamo = setEndpoint False "localhost" 8000 dynamoDB 174 | runResourceT $ runAWST env $ reconfigure dynamo $ runExceptT (x) 175 | 176 | start :: Config -> ExceptT EventStoreError IO () 177 | start parsedConfig = do 178 | let tableName = (T.pack . configTableName) parsedConfig 179 | metrics <- liftIO startMetrics 180 | --logger <- liftIO $ newLogger AWS.Error stdout 181 | ---awsEnv <- set envLogger logger <$> newEnv Sydney Discover 182 | awsEnv <- newEnv Discover 183 | let interperter2 = 184 | (if configLocalDynamoDB parsedConfig 185 | then runDynamoLocal' 186 | else runDynamoCloud') 187 | let runtimeEnvironment = 188 | RuntimeEnvironment 189 | { _runtimeEnvironmentMetricLogs = metrics 190 | , _runtimeEnvironmentAmazonkaEnv = awsEnv 191 | , _runtimeEnvironmentTableName = tableName 192 | } 193 | let runner2 p = interperter2 runtimeEnvironment p 194 | tableAlreadyExists <- 195 | toApplicationError (interperter2 runtimeEnvironment) $ 196 | doesTableExist tableName 197 | let shouldCreateTable = configCreateTable parsedConfig 198 | when 199 | (not tableAlreadyExists && shouldCreateTable) 200 | (putStrLn "Creating table..." >> 201 | toApplicationError 202 | (interperter2 runtimeEnvironment) 203 | (buildTable tableName) >> 204 | putStrLn "Table created") 205 | if tableAlreadyExists || shouldCreateTable 206 | then runApp runner2 tableName 207 | else failNoTable 208 | where 209 | runApp 210 | :: (forall a. EventStore a -> IO (Either EventStoreError a)) 211 | -> Text 212 | -> ExceptT EventStoreError IO () 213 | runApp runner _tableName 214 | = do 215 | liftIO $ forkGlobalFeedWriter runner 216 | liftIO $ startWebServer runner parsedConfig 217 | failNoTable = putStrLn "Table does not exist" 218 | 219 | checkForFailureOnExit :: ExceptT EventStoreError IO () -> IO () 220 | checkForFailureOnExit a = do 221 | result <- runExceptT a 222 | case result of 223 | Left m -> do 224 | printError m 225 | exitWith $ ExitFailure 1 226 | Right () -> return () 227 | 228 | main :: IO () 229 | main = Opt.execParser opts >>= checkForFailureOnExit . start 230 | where 231 | opts = 232 | info 233 | (Opt.helper <*> config) 234 | (fullDesc <> Opt.progDesc "DynamoDB event store" <> 235 | Opt.header 236 | "DynamoDB Event Store - all your events are belong to us") 237 | -------------------------------------------------------------------------------- /dynamodb-eventstore/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Andrew Browne 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /dynamodb-eventstore/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /dynamodb-eventstore/dynamodb-eventstore.cabal: -------------------------------------------------------------------------------- 1 | -- Initial DynamoEventStore.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: dynamodb-eventstore 5 | version: 0.1.0.0 6 | synopsis: EventStore implementation on top of AWS DynamoDB 7 | -- description: 8 | homepage: http://github.com/adbrowne/DynamoEventStore 9 | license: MIT 10 | license-file: LICENSE 11 | author: Andrew Browne 12 | maintainer: brownie@brownie.com.au 13 | -- copyright: 14 | category: Database 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=1.10 18 | 19 | library 20 | GHC-Options: -Wall 21 | exposed-modules: DynamoDbEventStore, 22 | DynamoDbEventStore.Types, 23 | DynamoDbEventStore.EventStoreCommands, 24 | DynamoDbEventStore.ProjectPrelude, 25 | DynamoDbEventStore.Storage.HeadItem, 26 | DynamoDbEventStore.Storage.StreamItem, 27 | DynamoDbEventStore.Storage.GlobalStreamItem, 28 | DynamoDbEventStore.Streams, 29 | DynamoDbEventStore.GlobalFeedWriter, 30 | DynamoDbEventStore.Constants, 31 | DynamoDbEventStore.AmazonkaImplementation 32 | default-extensions: NoImplicitPrelude 33 | build-depends: base, 34 | basic-prelude, 35 | scotty >= 0.9, 36 | safe >= 0.3, 37 | text >= 1.0, 38 | mmorph, 39 | cereal, 40 | async, 41 | stm, 42 | lrucache, 43 | foldl, 44 | dodgerblue, 45 | vector, 46 | adjunctions, 47 | either, 48 | hashable, 49 | uuid, 50 | feed, 51 | errors, 52 | containers >= 0.5, 53 | http-types >= 0.8, 54 | attoparsec >= 0.12, 55 | text-show >= 2, 56 | QuickCheck, 57 | quickcheck-instances, 58 | bytestring >= 0.10, 59 | time >= 1.4, 60 | aeson >= 0.8, 61 | aeson-pretty, 62 | random >= 1.1, 63 | transformers >= 0.4, 64 | transformers-base, 65 | mtl, 66 | text-format, 67 | aeson, 68 | unordered-containers, 69 | semigroups, 70 | pipes, 71 | exceptions, 72 | monad-control, 73 | lens, 74 | HTTP, 75 | blaze-markup, 76 | amazonka >= 1.0, 77 | amazonka-core >= 1.0, 78 | amazonka-dynamodb >= 1.0, 79 | resourcet, 80 | ekg-core 81 | hs-source-dirs: src 82 | default-language: Haskell2010 83 | 84 | Test-Suite tasty 85 | default-extensions: NoImplicitPrelude 86 | other-modules: DynamoCmdAmazonkaTests 87 | , DynamoDbEventStore.DynamoCmdInterpreter 88 | , DynamoDbEventStore.GlobalFeedWriterSpec 89 | , DynamoDbEventStore.InMemoryCache 90 | , DynamoDbEventStore.InMemoryDynamoTable 91 | type: exitcode-stdio-1.0 92 | main-is: tastytests.hs 93 | hs-source-dirs: tests 94 | build-depends: base, 95 | basic-prelude, 96 | tasty >= 0.10, 97 | tasty-hspec >= 1.0, 98 | tasty-hunit >= 0.9, 99 | tasty-quickcheck >= 0.8, 100 | text-show >= 2, 101 | pipes, 102 | foldl, 103 | QuickCheck, 104 | safe, 105 | lrucache, 106 | quickcheck-instances, 107 | dodgerblue, 108 | cereal, 109 | time, 110 | uuid, 111 | stm, 112 | either, 113 | random, 114 | containers >= 0.5, 115 | aeson, 116 | async, 117 | aeson-pretty, 118 | MonadRandom, 119 | semigroups, 120 | unordered-containers, 121 | hashable, 122 | amazonka-dynamodb, 123 | lens, 124 | http-types >= 0.8, 125 | mtl >= 2.1, 126 | transformers, 127 | transformers-base, 128 | monad-loops, 129 | blaze-markup, 130 | wai >= 3.0, 131 | wai-extra >= 3.0, 132 | scotty >= 0.9, 133 | free >= 4.10, 134 | bytestring >= 0.10, 135 | text >= 1.2, 136 | dynamodb-eventstore, 137 | ekg-core 138 | 139 | default-language: Haskell2010 140 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore.hs: -------------------------------------------------------------------------------- 1 | module DynamoDbEventStore 2 | (streamEventsProducer 3 | ,globalEventsProducer 4 | ,globalEventKeysProducer 5 | ,writeEvent 6 | ,readEvent 7 | ,buildTable 8 | ,doesTableExist 9 | ,runGlobalFeedWriter 10 | ,RuntimeEnvironment(..) 11 | ,GlobalFeedPosition(..) 12 | ,RecordedEvent(..) 13 | ,StreamId(..) 14 | ,EventStoreError(..) 15 | ,EventStoreActionError(..) 16 | ,EventStore 17 | ,Streams.EventWriteResult(..) 18 | ,EventEntry(..) 19 | ,EventType(..) 20 | ,EventTime(..) 21 | ,MetricLogs(..) 22 | ,MetricLogsPair(..) 23 | ,InterpreterError(..)) 24 | where 25 | 26 | import DynamoDbEventStore.ProjectPrelude 27 | import Control.Monad.State 28 | import qualified DynamoDbEventStore.Streams as Streams 29 | import DynamoDbEventStore.Types 30 | (RecordedEvent(..),QueryDirection,StreamId(..),EventStoreActionError,GlobalFeedPosition(..),EventKey) 31 | import DynamoDbEventStore.AmazonkaImplementation (RuntimeEnvironment(..), InterpreterError(..), MyAwsM(..),MetricLogs(..),MetricLogsPair(..)) 32 | import qualified DynamoDbEventStore.AmazonkaImplementation as AWS 33 | import DynamoDbEventStore.Storage.StreamItem (EventEntry(..),EventType(..),EventTime(..)) 34 | import qualified DynamoDbEventStore.GlobalFeedWriter as GlobalFeedWriter 35 | import Control.Monad.Trans.AWS 36 | import Control.Monad.Trans.Resource 37 | import Control.Monad.Morph 38 | 39 | data EventStoreError = 40 | EventStoreErrorInterpreter InterpreterError 41 | | EventStoreErrorAction EventStoreActionError 42 | deriving (Show, Eq) 43 | 44 | type EventStore = ExceptT EventStoreError (AWST' RuntimeEnvironment (ResourceT IO)) 45 | 46 | hoistDsl 47 | :: (ExceptT EventStoreActionError MyAwsM) a -> (ExceptT EventStoreError (AWST' RuntimeEnvironment (ResourceT IO))) a 48 | hoistDsl = combineErrors . hoist unMyAwsM 49 | 50 | buildTable :: Text -> EventStore () 51 | buildTable tableName = hoistDsl $ lift $ AWS.buildTable tableName 52 | 53 | doesTableExist :: Text -> EventStore Bool 54 | doesTableExist tableName = hoistDsl $ lift $ AWS.doesTableExist tableName 55 | 56 | streamEventsProducer :: QueryDirection -> StreamId -> Maybe Int64 -> Natural -> Producer RecordedEvent EventStore () 57 | streamEventsProducer direction streamId lastEvent batchSize = 58 | hoist hoistDsl $ Streams.streamEventsProducer direction streamId lastEvent batchSize 59 | 60 | globalEventsProducer :: QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, RecordedEvent) EventStore () 61 | globalEventsProducer direction startPosition = 62 | hoist hoistDsl $ Streams.globalEventsProducer direction startPosition 63 | 64 | globalEventKeysProducer :: QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, EventKey) EventStore () 65 | globalEventKeysProducer direction startPosition = 66 | hoist hoistDsl $ Streams.globalEventKeysProducer direction startPosition 67 | 68 | readEvent :: StreamId -> Int64 -> EventStore (Maybe RecordedEvent) 69 | readEvent streamId eventNumber = 70 | hoistDsl $ Streams.readEvent streamId eventNumber 71 | 72 | writeEvent :: StreamId -> Maybe Int64 -> NonEmpty EventEntry -> EventStore Streams.EventWriteResult 73 | writeEvent streamId ev eventEntries = hoistDsl $ Streams.writeEvent streamId ev eventEntries 74 | 75 | combineErrors :: ExceptT 76 | EventStoreActionError 77 | (ExceptT 78 | InterpreterError (AWST' RuntimeEnvironment (ResourceT IO))) 79 | a 80 | -> EventStore a 81 | combineErrors a = do 82 | r <- lift $ runExceptT (runExceptT a) 83 | case r of (Left e) -> throwError $ EventStoreErrorInterpreter e 84 | (Right (Left e)) -> throwError $ EventStoreErrorAction e 85 | (Right (Right result)) -> return result 86 | 87 | runGlobalFeedWriter :: EventStore () 88 | runGlobalFeedWriter = 89 | evalStateT (hoist hoistDsl GlobalFeedWriter.main) GlobalFeedWriter.emptyGlobalFeedWriterState 90 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/Constants.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module DynamoDbEventStore.Constants where 4 | 5 | import BasicPrelude 6 | 7 | needsPagingKey :: Text 8 | needsPagingKey = "NeedsPaging" 9 | 10 | eventCountKey :: Text 11 | eventCountKey = "EventCount" 12 | 13 | pageIsVerifiedKey :: Text 14 | pageIsVerifiedKey = "Verified" 15 | 16 | streamDynamoKeyPrefix :: Text 17 | streamDynamoKeyPrefix = "stream$" 18 | 19 | eventCreatedKey :: Text 20 | eventCreatedKey = "EventCreated" 21 | 22 | isJsonKey :: Text 23 | isJsonKey = "IsJson" 24 | 25 | eventPageNumberKey :: Text 26 | eventPageNumberKey = "PageNumber" 27 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/EventStoreCommands.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module DynamoDbEventStore.EventStoreCommands( 9 | StreamId(..), 10 | LogLevel(..), 11 | readField, 12 | readExcept, 13 | dynamoWriteWithRetry, 14 | updateItemWithRetry, 15 | MonadEsDsl(..), 16 | MonadEsDslWithFork(..), 17 | MyAwsM(..), 18 | DynamoVersion, 19 | QueryDirection(..), 20 | RecordedEvent(..), 21 | DynamoKey(..), 22 | DynamoWriteResult(..), 23 | DynamoReadResult(..), 24 | DynamoValues, 25 | ValueUpdate(..), 26 | PageKey(..), 27 | FeedEntry(..) 28 | ) where 29 | import BasicPrelude hiding (log) 30 | import System.Metrics.Counter 31 | import Control.Concurrent.Async hiding (wait) 32 | import Control.Concurrent.STM 33 | import Control.Lens hiding ((.=)) 34 | import Control.Monad.Except 35 | import Control.Monad.Reader 36 | import Control.Monad.State 37 | import qualified DodgerBlue.IO as DodgerIO 38 | import GHC.Natural 39 | 40 | import Control.Monad.Trans.AWS hiding (LogLevel) 41 | import Control.Monad.Trans.Resource 42 | import DynamoDbEventStore.AmazonkaImplementation 43 | import DynamoDbEventStore.Types 44 | import Network.AWS.DynamoDB hiding (updateItem) 45 | 46 | class MonadEsDsl m => MonadEsDslWithFork m where 47 | forkChild :: Text -> m () -> m () 48 | 49 | class Monad m => MonadEsDsl m where 50 | type QueueType m :: * -> * 51 | type CacheType m :: * -> * -> * 52 | type CounterType m :: * 53 | newCounter :: Text -> m (CounterType m) 54 | incrimentCounter :: CounterType m -> m () 55 | newCache :: forall v k. (Typeable v, Typeable k, Ord k) => Integer -> m (CacheType m k v) 56 | cacheInsert :: (Typeable k, Ord k, Typeable v) => CacheType m k v -> k -> v -> m () 57 | cacheLookup :: (Typeable k, Ord k, Typeable v) => CacheType m k v -> k -> m (Maybe v) 58 | newQueue :: forall a. Typeable a => m (QueueType m a) 59 | writeQueue :: forall a. Typeable a => QueueType m a -> a -> m () 60 | readQueue :: forall a. Typeable a => QueueType m a -> m a 61 | tryReadQueue :: forall a. Typeable a => QueueType m a -> m (Maybe a) 62 | readFromDynamo :: DynamoKey -> m (Maybe DynamoReadResult) 63 | writeToDynamo :: DynamoKey -> DynamoValues -> DynamoVersion -> m DynamoWriteResult 64 | queryTable :: QueryDirection -> Text -> Natural -> Maybe Int64 -> m [DynamoReadResult] 65 | updateItem :: DynamoKey -> HashMap Text ValueUpdate -> m Bool 66 | log :: LogLevel -> Text -> m () 67 | scanNeedsPaging :: m [DynamoKey] 68 | wait :: Int -> m () 69 | setPulseStatus :: Bool -> m () 70 | 71 | forkChildIO :: Text -> MyAwsM () -> MyAwsM () 72 | forkChildIO _childThreadName (MyAwsM c) = MyAwsM $ do 73 | runtimeEnv <- ask 74 | _ <- lift $ allocate (async (runResourceT $ runAWST runtimeEnv (runExceptT c))) cancel 75 | return () 76 | 77 | instance MonadEsDsl MyAwsM where 78 | type QueueType MyAwsM = TQueue 79 | type CacheType MyAwsM = InMemoryCache 80 | type CounterType MyAwsM = Counter 81 | newQueue = MyAwsM DodgerIO.newQueue 82 | writeQueue q a = MyAwsM $ DodgerIO.writeQueue q a 83 | readQueue = MyAwsM . DodgerIO.readQueue 84 | tryReadQueue = MyAwsM . DodgerIO.tryReadQueue 85 | newCounter = newCounterAws 86 | incrimentCounter = incrimentCounterAws 87 | newCache = newCacheAws 88 | cacheInsert = cacheInsertAws 89 | cacheLookup = cacheLookupAws 90 | readFromDynamo = readFromDynamoAws 91 | writeToDynamo = writeToDynamoAws 92 | updateItem = updateItemAws 93 | queryTable = queryTableAws 94 | log = logAws 95 | scanNeedsPaging = scanNeedsPagingAws 96 | wait = waitAws 97 | setPulseStatus = setPulseStatusAws 98 | 99 | instance MonadEsDslWithFork MyAwsM where 100 | forkChild = forkChildIO 101 | 102 | instance MonadEsDsl m => MonadEsDsl (StateT s m) where 103 | type QueueType (StateT s m) = QueueType m 104 | type CacheType (StateT s m) = CacheType m 105 | type CounterType (StateT s m) = CounterType m 106 | newQueue = lift newQueue 107 | writeQueue q a = lift $ writeQueue q a 108 | readQueue = lift . readQueue 109 | tryReadQueue = lift . tryReadQueue 110 | newCounter = lift . newCounter 111 | incrimentCounter = lift . incrimentCounter 112 | newCache = lift . newCache 113 | cacheInsert a b c = lift $ cacheInsert a b c 114 | cacheLookup a b = lift $ cacheLookup a b 115 | readFromDynamo = lift . readFromDynamo 116 | writeToDynamo a b c = lift $ writeToDynamo a b c 117 | updateItem a b = lift $ updateItem a b 118 | queryTable a b c d = lift $ queryTable a b c d 119 | log a b = lift $ log a b 120 | scanNeedsPaging = lift scanNeedsPaging 121 | wait = lift . wait 122 | setPulseStatus = lift . setPulseStatus 123 | 124 | instance MonadEsDsl m => MonadEsDsl (ExceptT e m) where 125 | type QueueType (ExceptT e m) = QueueType m 126 | type CacheType (ExceptT s m) = CacheType m 127 | type CounterType (ExceptT s m) = CounterType m 128 | newQueue = lift newQueue 129 | writeQueue q a = lift $ writeQueue q a 130 | readQueue = lift . readQueue 131 | tryReadQueue = lift . tryReadQueue 132 | newCounter = lift . newCounter 133 | incrimentCounter = lift . incrimentCounter 134 | newCache = lift . newCache 135 | cacheInsert a b c = lift $ cacheInsert a b c 136 | cacheLookup a b = lift $ cacheLookup a b 137 | readFromDynamo = lift . readFromDynamo 138 | writeToDynamo a b c = lift $ writeToDynamo a b c 139 | updateItem a b = lift $ updateItem a b 140 | queryTable a b c d = lift $ queryTable a b c d 141 | log a b = lift $ log a b 142 | scanNeedsPaging = lift scanNeedsPaging 143 | wait = lift . wait 144 | setPulseStatus = lift . setPulseStatus 145 | 146 | readField :: (MonadError e m) => (Text -> e) -> Text -> Lens' AttributeValue (Maybe a) -> DynamoValues -> m a 147 | readField = readFieldGeneric 148 | 149 | readExcept :: (MonadError e m) => (Read a) => (Text -> e) -> Text -> m a 150 | readExcept err t = 151 | let 152 | parsed = BasicPrelude.readMay t 153 | in case parsed of Nothing -> throwError $ err t 154 | (Just a) -> return a 155 | 156 | loopUntilSuccess :: Monad m => Integer -> (a -> Bool) -> m a -> m a 157 | loopUntilSuccess maxTries f action = 158 | action >>= loop (maxTries - 1) 159 | where 160 | loop 0 lastResult = return lastResult 161 | loop _ lastResult | f lastResult = return lastResult 162 | loop triesRemaining _ = action >>= loop (triesRemaining - 1) 163 | 164 | dynamoWriteWithRetry :: (MonadEsDsl m, MonadError EventStoreActionError m) => DynamoKey -> DynamoValues -> Int -> m DynamoWriteResult 165 | dynamoWriteWithRetry key value version = do 166 | finalResult <- loopUntilSuccess 100 (/= DynamoWriteFailure) (writeToDynamo key value version) 167 | checkFinalResult finalResult 168 | where 169 | checkFinalResult DynamoWriteSuccess = return DynamoWriteSuccess 170 | checkFinalResult DynamoWriteWrongVersion = return DynamoWriteWrongVersion 171 | checkFinalResult DynamoWriteFailure = throwError $ EventStoreActionErrorWriteFailure key 172 | 173 | updateItemWithRetry :: (MonadEsDsl m, MonadError EventStoreActionError m) => DynamoKey -> HashMap Text ValueUpdate -> m () 174 | updateItemWithRetry key updates = do 175 | result <- loopUntilSuccess 100 id (updateItem key updates) 176 | unless result (throwError $ EventStoreActionErrorUpdateFailure key) 177 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/GlobalFeedWriter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | module DynamoDbEventStore.GlobalFeedWriter ( 9 | main, 10 | dynamoWriteWithRetry, 11 | entryEventCount, 12 | emptyGlobalFeedWriterState, 13 | GlobalFeedWriterState(..), 14 | PageKeyPosition(..), 15 | DynamoCmdWithErrors, 16 | GlobalFeedPosition(..), 17 | EventStoreActionError(..)) where 18 | 19 | import BasicPrelude hiding (log) 20 | import Control.Exception (throw) 21 | import qualified Control.Foldl as Foldl 22 | import Control.Lens 23 | import Data.List.NonEmpty (NonEmpty(..)) 24 | import Control.Monad.Except 25 | import Control.Monad.State 26 | import Data.Foldable 27 | import qualified Data.HashMap.Lazy as HM 28 | import qualified Data.Sequence as Seq 29 | import qualified Data.Set as Set 30 | import qualified Data.Text as T 31 | import qualified DynamoDbEventStore.Constants as Constants 32 | import DynamoDbEventStore.EventStoreCommands 33 | import DynamoDbEventStore.Storage.HeadItem (getLastVerifiedPage, trySetLastVerifiedPage) 34 | import DynamoDbEventStore.Storage.StreamItem (streamEntryFirstEventNumber,StreamEntry(..), getStreamIdFromDynamoKey,streamEntryProducer) 35 | import DynamoDbEventStore.Storage.GlobalStreamItem (GlobalFeedItem(..), globalFeedItemsProducer,PageStatus(..),writeGlobalFeedItem, updatePageStatus, firstPageKey, readPage) 36 | import Pipes ((>->),Producer,yield) 37 | import qualified Pipes.Prelude as P 38 | import DynamoDbEventStore.Types 39 | import Network.AWS.DynamoDB hiding (updateItem) 40 | import Safe 41 | 42 | type DynamoCmdWithErrors q m = (MonadEsDsl m, MonadError EventStoreActionError m) 43 | 44 | entryEventCount :: (MonadError EventStoreActionError m) => DynamoReadResult -> m Int 45 | entryEventCount dynamoItem = 46 | let 47 | value = dynamoItem & 48 | dynamoReadResultValue & 49 | view (ix Constants.eventCountKey . avN) 50 | parsedValue = value >>= (Safe.readMay . T.unpack) 51 | in case parsedValue of Nothing -> throwError $ EventStoreActionErrorCouldNotReadEventCount value 52 | (Just x) -> return x 53 | 54 | toDynamoKey :: StreamId -> Int64 -> DynamoKey 55 | toDynamoKey (StreamId streamId) = DynamoKey (Constants.streamDynamoKeyPrefix <> streamId) 56 | 57 | setEventEntryPage :: (MonadEsDsl m, MonadError EventStoreActionError m) => DynamoKey -> PageKey -> m () 58 | setEventEntryPage key (PageKey pageNumber) = do 59 | let updates = 60 | HM.fromList [ 61 | (Constants.needsPagingKey, ValueUpdateDelete) 62 | , (Constants.eventPageNumberKey, ValueUpdateSet (set avS (Just (tshow pageNumber)) attributeValue)) 63 | ] 64 | updateItemWithRetry key updates 65 | 66 | setFeedEntryPageNumber :: 67 | (MonadEsDsl m, MonadError EventStoreActionError m) 68 | => CounterType m 69 | -> PageKey 70 | -> FeedEntry 71 | -> m () 72 | 73 | setFeedEntryPageNumber itemCounter pageNumber feedEntry = do 74 | let streamId = feedEntryStream feedEntry 75 | let dynamoKey = toDynamoKey streamId (feedEntryNumber feedEntry) 76 | void $ setEventEntryPage dynamoKey pageNumber 77 | incrimentCounter itemCounter 78 | 79 | verifyPage :: 80 | (MonadError EventStoreActionError m, MonadEsDsl m) 81 | => CounterType m 82 | -> QueueType m (PageKey, FeedEntry) 83 | -> QueueType m FeedEntry 84 | -> GlobalFeedItem 85 | -> m () 86 | verifyPage pageCounter workQueue doneQueue GlobalFeedItem{..} = do 87 | void $ traverse verifyItem globalFeedItemFeedEntries 88 | waitAll doneQueue (Set.fromList . toList $ globalFeedItemFeedEntries) 89 | updatePageStatus globalFeedItemPageKey PageStatusVerified 90 | trySetLastVerifiedPage globalFeedItemPageKey 91 | incrimentCounter pageCounter 92 | where 93 | verifyItem i = writeQueue workQueue (globalFeedItemPageKey,i) -- do 94 | --setFeedEntryPageNumber itemCounter globalFeedItemPageKey i 95 | waitAll :: (MonadEsDsl m, Ord a, Typeable a) => QueueType m a -> Set a -> m () 96 | waitAll _ itemSet | Set.null itemSet = return () 97 | waitAll q itemSet = do 98 | item <- readQueue q 99 | let itemSet' = Set.delete item itemSet 100 | waitAll q itemSet' 101 | 102 | startVerifying :: 103 | MonadEsDsl m 104 | => CounterType m 105 | -> QueueType m (PageKey, FeedEntry) 106 | -> QueueType m FeedEntry 107 | -> m () 108 | startVerifying verifiedPages workQueue doneQueue = 109 | throwOnLeft $ go firstPageKey 110 | where 111 | go pageKey = do 112 | result <- readPage pageKey 113 | maybe (pageDoesNotExist pageKey) pageExists result 114 | awaitPage pageKey = do 115 | setPulseStatus False 116 | wait 1000 117 | go pageKey 118 | pageDoesNotExist = awaitPage 119 | pageExists GlobalFeedItem { globalFeedItemPageStatus = PageStatusVerified, globalFeedItemPageKey = pageKey } = go (succ pageKey) 120 | pageExists x@GlobalFeedItem { globalFeedItemPageStatus = PageStatusComplete, globalFeedItemPageKey = pageKey } = 121 | setPulseStatus True >> verifyPage verifiedPages workQueue doneQueue x >> go (succ pageKey) 122 | 123 | verifyItemsThread :: MonadEsDsl m 124 | => CounterType m 125 | -> QueueType m (PageKey, FeedEntry) 126 | -> QueueType m FeedEntry 127 | -> m () 128 | verifyItemsThread itemCounter inQ outQ = 129 | throwOnLeft $ forever $ do 130 | (pageKey, item) <- readQueue inQ 131 | setFeedEntryPageNumber itemCounter pageKey item 132 | writeQueue outQ item 133 | 134 | verifyPagesThread :: MonadEsDslWithFork m => m () 135 | verifyPagesThread = do 136 | verifiedItems <- newCounter "dynamodb-eventstore.verifiedItems" 137 | verifiedPages <- newCounter "dynamodb-eventstore.verifiedPages" 138 | verifyItemQ <- newQueue 139 | verifyDoneQ <- newQueue 140 | replicateM_ 10 $ forkChild "verifyItemsThread" $ verifyItemsThread verifiedItems verifyItemQ verifyDoneQ 141 | startVerifying verifiedPages verifyItemQ verifyDoneQ 142 | 143 | data ToBePaged = 144 | ToBePaged { 145 | toBePagedEntries :: [FeedEntry], 146 | toBePagedVerifiedUpToPage :: Maybe PageKey } 147 | deriving (Show) 148 | 149 | instance Monoid ToBePaged where 150 | mempty = ToBePaged { 151 | toBePagedEntries = mempty, 152 | toBePagedVerifiedUpToPage = Nothing } 153 | mappend 154 | ToBePaged { toBePagedEntries = toBePagedEntries1, toBePagedVerifiedUpToPage = toBePagedVerifiedUpToPage1 } 155 | ToBePaged { toBePagedEntries = toBePagedEntries2, toBePagedVerifiedUpToPage = toBePagedVerifiedUpToPage2 } = ToBePaged (toBePagedEntries1 <> toBePagedEntries2) (minPageKey toBePagedVerifiedUpToPage1 toBePagedVerifiedUpToPage2) 156 | where 157 | minPageKey Nothing other = other 158 | minPageKey other Nothing = other 159 | minPageKey (Just pk1) (Just pk2) = Just $ min pk1 pk2 160 | 161 | streamEntryToFeedEntry :: StreamEntry -> FeedEntry 162 | streamEntryToFeedEntry StreamEntry{..} = 163 | FeedEntry { 164 | feedEntryStream = streamEntryStreamId, 165 | feedEntryNumber = streamEntryFirstEventNumber, 166 | feedEntryCount = length streamEntryEventEntries } 167 | 168 | collectAncestors 169 | :: (MonadEsDsl m, MonadError EventStoreActionError m) => 170 | StreamId -> 171 | m ToBePaged 172 | collectAncestors streamId = 173 | let 174 | streamFromEventBack = streamEntryProducer QueryDirectionBackward streamId Nothing 10 175 | in do 176 | lastVerifiedPage <- getLastVerifiedPage 177 | events <- P.toListM $ 178 | streamFromEventBack 179 | >-> P.takeWhile streamEntryNeedsPaging 180 | >-> P.map streamEntryToFeedEntry 181 | return $ ToBePaged events lastVerifiedPage 182 | 183 | collectAncestorsThread :: 184 | (MonadEsDsl m) => 185 | QueueType m StreamId -> 186 | QueueType m ToBePaged -> 187 | m () 188 | collectAncestorsThread inQ outQ = 189 | throwOnLeft $ forever $ do 190 | i <- readQueue inQ 191 | result <- collectAncestors i 192 | writeQueue outQ result 193 | 194 | data PageUpdate = 195 | PageUpdate { 196 | pageUpdatePageKey :: PageKey, 197 | pageUpdateNewEntries :: Seq FeedEntry, 198 | pageUpdatePageVersion :: DynamoVersion } 199 | deriving Show 200 | 201 | data FeedPage = FeedPage { 202 | feedPageKey :: PageKey, 203 | feedPageItems :: Set FeedEntry } 204 | 205 | feedPageProducerForward :: (MonadEsDsl m, MonadError EventStoreActionError m) 206 | => CacheType m PageKey (Set FeedEntry) 207 | -> Maybe PageKey 208 | -> Producer FeedPage m () 209 | feedPageProducerForward completePageCache Nothing = feedPageProducerForward completePageCache (Just firstPageKey) 210 | feedPageProducerForward completePageCache (Just page) = do 211 | cacheResult <- lift $ cacheLookup completePageCache page 212 | maybe lookupDb yieldAndLoop cacheResult 213 | where 214 | lookupDb = 215 | globalFeedItemsProducer QueryDirectionForward False (Just page) 216 | >-> 217 | P.map globalFeedItemToFeedPage 218 | globalFeedItemToFeedPage GlobalFeedItem{..} = 219 | FeedPage globalFeedItemPageKey (Set.fromList . toList $ globalFeedItemFeedEntries) 220 | yieldAndLoop feedEntries = do 221 | yield $ FeedPage page feedEntries 222 | feedPageProducerForward completePageCache (Just $ page + 1) 223 | 224 | writeItemsToPage 225 | :: (MonadEsDsl m, MonadError EventStoreActionError m) => 226 | CacheType m PageKey (Set FeedEntry) -> 227 | ToBePaged -> 228 | m (Maybe PageUpdate) 229 | writeItemsToPage completePageCache ToBePaged{..} = 230 | let 231 | toBePagedSet = Set.fromList . toList $ toBePagedEntries 232 | removePagedItem s FeedPage{..} = Set.difference s feedPageItems 233 | filteredItemsToPage = Foldl.Fold removePagedItem toBePagedSet id 234 | combinedFold = (,) <$> filteredItemsToPage <*> Foldl.last 235 | foldOverProducer = Foldl.purely P.fold 236 | result = foldOverProducer combinedFold $ feedPageProducerForward completePageCache toBePagedVerifiedUpToPage 237 | in do 238 | (finalFeedEntries, lastPage) <- result 239 | let pageKey = getNextPageKey lastPage 240 | let sortedNewFeedEntries = (Seq.fromList . sort . toList) finalFeedEntries 241 | let pageVersion = 0 242 | let page = GlobalFeedItem { 243 | globalFeedItemPageKey = pageKey, 244 | globalFeedItemPageStatus = PageStatusComplete, 245 | globalFeedItemVersion = pageVersion, 246 | globalFeedItemFeedEntries = sortedNewFeedEntries } 247 | _ <- writeGlobalFeedItem page -- todo don't ignore errors 248 | cacheInsert completePageCache pageKey (Set.fromList . toList $ sortedNewFeedEntries) 249 | log Debug ("paged: " <> (tshow . length) sortedNewFeedEntries) 250 | return . Just $ PageUpdate { 251 | pageUpdatePageKey = pageKey, 252 | pageUpdateNewEntries = sortedNewFeedEntries, 253 | pageUpdatePageVersion = pageVersion } 254 | where 255 | getNextPageKey Nothing = firstPageKey 256 | getNextPageKey (Just FeedPage {..}) = feedPageKey + 1 257 | 258 | throwOnLeft :: MonadEsDsl m => ExceptT EventStoreActionError m () -> m () 259 | throwOnLeft action = do 260 | result <- runExceptT action 261 | case result of Left e -> do 262 | log Error (tshow e) 263 | throw e 264 | Right () -> return () 265 | 266 | collectAllAvailable :: (Typeable a, MonadEsDsl m) => QueueType m a -> m (NonEmpty a) 267 | collectAllAvailable q = do 268 | firstItem <- readQueue q 269 | moreItems <- tryReadMore [] 270 | return $ firstItem :| moreItems 271 | where 272 | tryReadMore acc = do 273 | result <- tryReadQueue q 274 | maybe (return acc) (\x -> tryReadMore (x:acc)) result 275 | 276 | writeItemsToPageThread 277 | :: (MonadEsDsl m) => 278 | CacheType m PageKey (Set FeedEntry) -> 279 | QueueType m ToBePaged -> 280 | m () 281 | writeItemsToPageThread completePageCache inQ = throwOnLeft . forever $ do 282 | items <- collectAllAvailable inQ 283 | _ <- writeItemsToPage completePageCache (fold items) 284 | return () 285 | 286 | data GlobalFeedWriterState = GlobalFeedWriterState { 287 | globalFeedWriterStateCurrentPage :: Maybe PageKey -- we don't always know the current page 288 | } 289 | 290 | emptyGlobalFeedWriterState :: GlobalFeedWriterState 291 | emptyGlobalFeedWriterState = GlobalFeedWriterState { 292 | globalFeedWriterStateCurrentPage = Nothing 293 | } 294 | 295 | forkChild' :: (MonadEsDslWithFork m) => Text -> m () -> StateT GlobalFeedWriterState (ExceptT EventStoreActionError m) () 296 | 297 | forkChild' threadName c = lift $ lift $ forkChild threadName c 298 | 299 | data PageKeyPosition = 300 | PageKeyPositionLastComplete 301 | | PageKeyPositionLastVerified 302 | deriving (Eq, Ord, Show) 303 | 304 | scanNeedsPagingIndex :: MonadEsDsl m => QueueType m StreamId -> m () 305 | scanNeedsPagingIndex itemsToPageQueue = 306 | let 307 | go cache = do 308 | scanResult <- scanNeedsPaging 309 | (filteredScan :: [DynamoKey]) <- filterM (notInCache cache) scanResult 310 | let streams = toList . Set.fromList $ getStreamIdFromDynamoKey <$> filteredScan 311 | _ <- traverse (writeQueue itemsToPageQueue) streams 312 | unless (null filteredScan) (log Debug $ "Scanned new:" <> (tshow . length) filteredScan) 313 | when (null scanResult) (wait 1000) 314 | let isActive = not (null scanResult) 315 | setPulseStatus isActive 316 | _ <- traverse (\k -> cacheInsert cache k True) filteredScan 317 | go cache 318 | notInCache cache dynamoKey = do 319 | result <- cacheLookup cache dynamoKey 320 | return $ isNothing result 321 | in do 322 | cache <- newCache 100000 323 | go cache 324 | 325 | main :: MonadEsDslWithFork m => StateT GlobalFeedWriterState (ExceptT EventStoreActionError m) () 326 | main = do 327 | itemsToPageQueue <- newQueue 328 | itemsReadyForGlobalFeed <- newQueue 329 | completePageCache <- newCache 1000 330 | let startCollectAncestorsThread = forkChild' "collectAncestorsThread" $ collectAncestorsThread itemsToPageQueue itemsReadyForGlobalFeed 331 | replicateM_ 10 startCollectAncestorsThread 332 | forkChild' "writeItemsToPageThread" $ writeItemsToPageThread completePageCache itemsReadyForGlobalFeed 333 | forkChild' "verifyPagesThread" verifyPagesThread 334 | scanNeedsPagingIndex itemsToPageQueue 335 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/ProjectPrelude.hs: -------------------------------------------------------------------------------- 1 | module DynamoDbEventStore.ProjectPrelude 2 | (traceM 3 | ,module X 4 | ,NonEmpty(..) 5 | ,fmap2 6 | ,Foldable.traverse_ 7 | ) where 8 | 9 | import BasicPrelude as X 10 | import GHC.Natural as X 11 | import Control.Monad.Except as X 12 | import Pipes as X (Producer, yield, await, (>->), Pipe) 13 | import Data.List.NonEmpty (NonEmpty(..)) 14 | import Data.Foldable as Foldable 15 | 16 | import qualified Debug.Trace 17 | import Data.Text as T 18 | 19 | {-# WARNING traceM "traceM still in code" #-} 20 | traceM :: Monad m => T.Text -> m () 21 | traceM = Debug.Trace.traceM . T.unpack 22 | 23 | fmap2 24 | :: (Functor f, Functor f1) 25 | => (a -> b) -> f (f1 a) -> f (f1 b) 26 | fmap2 = fmap . fmap 27 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/Storage/GlobalStreamItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | module DynamoDbEventStore.Storage.GlobalStreamItem 7 | (GlobalFeedItem(..) 8 | ,globalFeedItemsProducer 9 | ,PageStatus(..) 10 | ,firstPageKey 11 | ,readPage 12 | ,readPageMustExist 13 | ,writePage 14 | ,writeGlobalFeedItem 15 | ,updatePageStatus 16 | ) where 17 | 18 | import BasicPrelude hiding (log) 19 | import Control.Lens 20 | import Control.Monad.Except 21 | import Text.Printf (printf) 22 | import qualified Data.Text as T 23 | import qualified Data.Aeson as Aeson 24 | import qualified Data.ByteString as BS 25 | import qualified Data.ByteString.Lazy as BL 26 | import qualified Data.HashMap.Lazy as HM 27 | import Pipes (Producer,yield) 28 | import Data.Either.Combinators (eitherToError) 29 | 30 | import qualified DynamoDbEventStore.EventStoreCommands as EventStoreCommands 31 | import DynamoDbEventStore.EventStoreCommands (MonadEsDsl, dynamoWriteWithRetry, readFromDynamo, readExcept, QueryDirection(..),ValueUpdate(..), updateItem, wait) 32 | import DynamoDbEventStore.Types (PageKey(..), DynamoVersion, FeedEntry(..), DynamoKey(..), DynamoWriteResult,EventStoreActionError(..),DynamoReadResult(..), DynamoValues) 33 | import Network.AWS.DynamoDB (AttributeValue,avB,avS,attributeValue) 34 | 35 | pageDynamoKeyPrefix :: Text 36 | pageDynamoKeyPrefix = "page$" 37 | 38 | pageBodyKey :: Text 39 | pageBodyKey = "Body" 40 | 41 | pageStatusKey :: Text 42 | pageStatusKey = "PageStatus" 43 | 44 | getPageDynamoKey :: PageKey -> DynamoKey 45 | getPageDynamoKey (PageKey pageNumber) = 46 | let paddedPageNumber = T.pack (printf "%08d" pageNumber) 47 | in DynamoKey (pageDynamoKeyPrefix <> paddedPageNumber) 0 48 | 49 | itemToJsonByteString :: Aeson.ToJSON a => a -> BS.ByteString 50 | itemToJsonByteString = BL.toStrict . Aeson.encode . Aeson.toJSON 51 | 52 | data GlobalFeedItem = 53 | GlobalFeedItem { 54 | globalFeedItemPageKey :: PageKey, 55 | globalFeedItemPageStatus :: PageStatus, 56 | globalFeedItemVersion :: DynamoVersion, 57 | globalFeedItemFeedEntries :: Seq FeedEntry } 58 | 59 | data PageStatus = 60 | PageStatusComplete 61 | | PageStatusVerified 62 | deriving (Read, Show, Eq) 63 | 64 | readField :: (MonadError EventStoreActionError m) => DynamoKey -> Text -> Lens' AttributeValue (Maybe a) -> DynamoValues -> m a 65 | readField dynamoKey = 66 | EventStoreCommands.readField (EventStoreActionErrorFieldMissing dynamoKey) 67 | 68 | jsonByteStringToItem :: (Aeson.FromJSON a, MonadError EventStoreActionError m) => ByteString -> m a 69 | jsonByteStringToItem a = eitherToError $ over _Left EventStoreActionErrorJsonDecodeError $ Aeson.eitherDecodeStrict a 70 | 71 | firstPageKey :: PageKey 72 | firstPageKey = PageKey 0 73 | 74 | readFeedEntries :: (MonadError EventStoreActionError m) => DynamoKey -> DynamoValues -> m (Seq FeedEntry) 75 | readFeedEntries dynamoKey values = do 76 | body <- readField dynamoKey pageBodyKey avB values 77 | jsonByteStringToItem body 78 | 79 | readPageStatus :: (MonadError EventStoreActionError m) => DynamoKey -> DynamoValues -> m PageStatus 80 | readPageStatus dynamoKey values = do 81 | pageStatus <- readField dynamoKey pageStatusKey avS values 82 | let formatError = EventStoreActionErrorPageStatusFieldFormat 83 | readExcept formatError pageStatus 84 | 85 | readPage :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> m (Maybe GlobalFeedItem) 86 | readPage pageKey = do 87 | let dynamoKey = getPageDynamoKey pageKey 88 | result <- readFromDynamo dynamoKey 89 | maybe (return Nothing) readResult result 90 | where 91 | readResult (DynamoReadResult key version values) = do 92 | feedEntries <- readFeedEntries key values 93 | pageStatus <- readPageStatus key values 94 | return (Just GlobalFeedItem { 95 | globalFeedItemFeedEntries = feedEntries, 96 | globalFeedItemPageKey = pageKey, 97 | globalFeedItemPageStatus = pageStatus, 98 | globalFeedItemVersion = version }) 99 | 100 | readPageMustExist :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> m GlobalFeedItem 101 | readPageMustExist pageKey = 102 | let 103 | onError = throwError $ EventStoreActionErrorPageDoesNotExist pageKey 104 | in do 105 | readResult <- readPage pageKey 106 | maybe onError return readResult 107 | 108 | globalFeedItemsProducerInternal :: (MonadEsDsl m, MonadError EventStoreActionError m) => (PageKey -> PageKey) -> Bool -> Maybe PageKey -> Producer GlobalFeedItem m () 109 | globalFeedItemsProducerInternal _next _waitForNewPages (Just (PageKey (-1))) = return () 110 | globalFeedItemsProducerInternal next waitForNewPages Nothing = globalFeedItemsProducerInternal next waitForNewPages (Just firstPageKey) 111 | globalFeedItemsProducerInternal next waitForNewPages (Just startPage) = do 112 | result <- lift $ readPage startPage 113 | maybe noResult yieldAndLoop result 114 | where 115 | yieldAndLoop a = do 116 | yield a 117 | globalFeedItemsProducerInternal next waitForNewPages $ Just (next startPage) 118 | noResult = 119 | when waitForNewPages $ do 120 | lift $ wait 1000 121 | globalFeedItemsProducerInternal next waitForNewPages $ Just startPage 122 | 123 | globalFeedItemsProducer :: (MonadError EventStoreActionError m, MonadEsDsl m) => QueryDirection -> Bool -> Maybe PageKey -> Producer GlobalFeedItem m () 124 | globalFeedItemsProducer QueryDirectionBackward = globalFeedItemsProducerInternal (\(PageKey p) -> PageKey (p - 1)) 125 | globalFeedItemsProducer QueryDirectionForward = globalFeedItemsProducerInternal (\(PageKey p) -> PageKey (p + 1)) 126 | 127 | writeGlobalFeedItem :: (MonadError EventStoreActionError m, MonadEsDsl m) => GlobalFeedItem -> m DynamoWriteResult 128 | writeGlobalFeedItem GlobalFeedItem{..} = 129 | writePage globalFeedItemPageKey globalFeedItemFeedEntries globalFeedItemVersion 130 | 131 | pageStatusToAttribute :: PageStatus -> AttributeValue 132 | pageStatusToAttribute pageStatus = 133 | set avS (Just (tshow pageStatus)) attributeValue 134 | 135 | updatePageStatus :: (MonadError EventStoreActionError m, MonadEsDsl m) => PageKey -> PageStatus -> m () 136 | updatePageStatus pageKey newStatus = 137 | let 138 | dynamoKey = getPageDynamoKey pageKey 139 | changes = HM.singleton pageStatusKey (ValueUpdateSet (pageStatusToAttribute newStatus)) 140 | in 141 | void $ updateItem dynamoKey changes 142 | 143 | writePage :: (MonadError EventStoreActionError m, MonadEsDsl m) => PageKey -> Seq FeedEntry -> DynamoVersion -> m DynamoWriteResult 144 | writePage pageNumber entries version = do 145 | let feedEntry = itemToJsonByteString entries 146 | let dynamoKey = getPageDynamoKey pageNumber 147 | let body = 148 | HM.singleton pageBodyKey (set avB (Just feedEntry) attributeValue) 149 | & HM.insert pageStatusKey (pageStatusToAttribute PageStatusComplete) 150 | dynamoWriteWithRetry dynamoKey body version 151 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/Storage/HeadItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | module DynamoDbEventStore.Storage.HeadItem ( 6 | getLastFullPage 7 | ,trySetLastFullPage 8 | ,trySetLastVerifiedPage 9 | ,getLastVerifiedPage) where 10 | 11 | import BasicPrelude 12 | import Control.Lens (set) 13 | import Control.Monad.Except 14 | import qualified Data.HashMap.Lazy as HM 15 | import Network.AWS.DynamoDB (avN,attributeValue) 16 | 17 | import DynamoDbEventStore.EventStoreCommands (MonadEsDsl,readExcept,readFromDynamo,readField,writeToDynamo) 18 | import DynamoDbEventStore.Types (EventStoreActionError(..),PageKey(..),DynamoReadResult(..),DynamoReadResult(..),DynamoKey(..)) 19 | 20 | headDynamoKey :: DynamoKey 21 | headDynamoKey = DynamoKey { dynamoKeyKey = "$head", dynamoKeyEventNumber = 0 } 22 | 23 | lastFullPageFieldKey :: Text 24 | lastFullPageFieldKey = "lastFull" 25 | 26 | lastVerifiedPageFieldKey ::Text 27 | lastVerifiedPageFieldKey = "lastVerified" 28 | 29 | data HeadData = HeadData { 30 | headDataLastFullPage :: Maybe PageKey, 31 | headDataLastVerifiedPage :: Maybe PageKey, 32 | headDataVersion :: Int } 33 | 34 | readPageField :: (MonadError EventStoreActionError m) => DynamoReadResult -> Text -> m PageKey 35 | readPageField DynamoReadResult{..} fieldKey = do 36 | let missingError = const (EventStoreActionErrorHeadFieldMissing fieldKey) 37 | fieldValue <- readField missingError fieldKey avN dynamoReadResultValue 38 | let formatError = EventStoreActionErrorHeadFieldFormat fieldKey 39 | numberValue <- readExcept formatError fieldValue 40 | return (PageKey numberValue) 41 | 42 | readHeadData :: (MonadEsDsl m, MonadError EventStoreActionError m) => m HeadData 43 | readHeadData = do 44 | currentHead <- readFromDynamo headDynamoKey 45 | readHead currentHead 46 | where 47 | readHead Nothing = return HeadData { 48 | headDataLastFullPage = Nothing, 49 | headDataLastVerifiedPage = Nothing, 50 | headDataVersion = 0 } 51 | readHead (Just readResult@DynamoReadResult{..}) = do 52 | lastFullPage <- readPageField readResult lastFullPageFieldKey 53 | lastVerifiedPage <- readPageField readResult lastVerifiedPageFieldKey 54 | return HeadData { 55 | headDataLastFullPage = Just lastFullPage, 56 | headDataLastVerifiedPage = Just lastVerifiedPage, 57 | headDataVersion = dynamoReadResultVersion } 58 | 59 | getLastVerifiedPage :: (MonadEsDsl m, MonadError EventStoreActionError m) => m (Maybe PageKey) 60 | getLastVerifiedPage = headDataLastVerifiedPage <$> readHeadData 61 | 62 | getLastFullPage :: (MonadEsDsl m, MonadError EventStoreActionError m) => m (Maybe PageKey) 63 | getLastFullPage = headDataLastFullPage <$> readHeadData 64 | 65 | trySetLastFullPage :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> m () 66 | trySetLastFullPage latestPage = do 67 | HeadData{..} <- readHeadData 68 | when (Just latestPage > headDataLastFullPage) $ do 69 | let value = HM.singleton lastFullPageFieldKey (set avN (Just . tshow $ latestPage) attributeValue) 70 | void (writeToDynamo headDynamoKey value (headDataVersion + 1)) 71 | return () 72 | 73 | trySetLastVerifiedPage :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> m () 74 | trySetLastVerifiedPage latestPage = do 75 | HeadData{..} <- readHeadData 76 | when (Just latestPage > headDataLastVerifiedPage) $ do 77 | let value = HM.singleton lastVerifiedPageFieldKey (set avN (Just . tshow $ latestPage) attributeValue) 78 | void (writeToDynamo headDynamoKey value (headDataVersion + 1)) 79 | return () 80 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/Storage/StreamItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | 9 | module DynamoDbEventStore.Storage.StreamItem ( 10 | StreamEntry(..) 11 | , dynamoReadResultToStreamEntry 12 | , getStreamIdFromDynamoKey 13 | , eventTypeToText 14 | , getLastStreamItem 15 | , unEventTime 16 | , streamEntryToValues 17 | , writeStreamItem 18 | , EventType(..) 19 | , EventEntry(..) 20 | , EventTime(..) 21 | , readStreamProducer 22 | , dynamoReadResultToEventNumber 23 | , streamEntryProducer) where 24 | 25 | import BasicPrelude 26 | import Control.Lens 27 | import qualified Data.Text as T 28 | import qualified Data.HashMap.Lazy as HM 29 | import Control.Monad.Except 30 | import Data.List.NonEmpty (NonEmpty (..)) 31 | import qualified Data.List.NonEmpty as NonEmpty 32 | import qualified Data.Serialize as Serialize 33 | import Data.Time.Clock 34 | import Data.Time.Format 35 | import qualified Data.Text.Lazy as TL 36 | import qualified Data.Text.Lazy.Encoding as TL 37 | import Data.Time.Calendar (Day) 38 | import qualified Data.ByteString.Lazy as BL 39 | import GHC.Generics 40 | import GHC.Natural 41 | import DynamoDbEventStore.EventStoreCommands (MonadEsDsl,queryTable,dynamoWriteWithRetry) 42 | import DynamoDbEventStore.AmazonkaImplementation (readFieldGeneric) 43 | import Network.AWS.DynamoDB (AttributeValue,avB,avN,avS,attributeValue) 44 | import qualified Pipes.Prelude as P 45 | import TextShow (showt) 46 | import qualified Test.QuickCheck as QC 47 | import Test.QuickCheck.Instances() 48 | import Pipes (Producer,yield,(>->)) 49 | 50 | import DynamoDbEventStore.Types (StreamId(..),DynamoReadResult(..),DynamoKey(..), EventId(..),EventStoreActionError(..),DynamoValues,QueryDirection(..),DynamoWriteResult) 51 | import qualified DynamoDbEventStore.Constants as Constants 52 | 53 | newtype EventType = EventType Text deriving (Show, Eq, Ord, IsString) 54 | instance Serialize.Serialize EventType where 55 | put (EventType t) = (Serialize.put . encodeUtf8) t 56 | get = EventType . decodeUtf8 <$> Serialize.get 57 | 58 | newtype EventTime = EventTime UTCTime deriving (Show, Eq, Ord) 59 | unEventTime :: EventTime -> UTCTime 60 | unEventTime (EventTime utcTime) = utcTime 61 | 62 | eventTypeToText :: EventType -> Text 63 | eventTypeToText (EventType t) = t 64 | 65 | data EventEntry = EventEntry { 66 | eventEntryData :: BL.ByteString, 67 | eventEntryType :: EventType, 68 | eventEntryEventId :: EventId, 69 | eventEntryCreated :: EventTime, 70 | eventEntryIsJson :: Bool 71 | } deriving (Show, Eq, Ord, Generic) 72 | 73 | instance Serialize.Serialize EventEntry 74 | 75 | instance QC.Arbitrary EventTime where 76 | arbitrary = 77 | EventTime <$> QC.arbitrary 78 | 79 | newtype SecondPrecisionUtcTime = SecondPrecisionUtcTime UTCTime 80 | 81 | instance QC.Arbitrary SecondPrecisionUtcTime where 82 | arbitrary = 83 | SecondPrecisionUtcTime <$> (UTCTime 84 | <$> (QC.arbitrary :: QC.Gen Day) 85 | <*> (secondsToDiffTime <$> QC.choose (0, 86400))) 86 | 87 | instance QC.Arbitrary EventEntry where 88 | arbitrary = EventEntry <$> (TL.encodeUtf8 . TL.pack <$> QC.arbitrary) 89 | <*> (EventType . fromString <$> QC.arbitrary) 90 | <*> QC.arbitrary 91 | <*> QC.arbitrary 92 | <*> QC.arbitrary 93 | 94 | newtype NonEmptyWrapper a = NonEmptyWrapper (NonEmpty a) 95 | instance Serialize.Serialize a => Serialize.Serialize (NonEmptyWrapper a) where 96 | put (NonEmptyWrapper xs) = Serialize.put (NonEmpty.toList xs) 97 | get = do 98 | xs <- Serialize.get 99 | maybe (fail "NonEmptyWrapper: found an empty list") (return . NonEmptyWrapper) (NonEmpty.nonEmpty xs) 100 | 101 | instance Serialize.Serialize EventTime where 102 | put (EventTime t) = (Serialize.put . formatTime defaultTimeLocale "%s%Q") t 103 | get = do 104 | textValue <- Serialize.get 105 | time <- parseTimeM False defaultTimeLocale "%s%Q" textValue 106 | return $ EventTime time 107 | 108 | data StreamEntry = StreamEntry { 109 | streamEntryStreamId :: StreamId, 110 | streamEntryFirstEventNumber :: Int64, 111 | streamEntryEventEntries :: NonEmpty EventEntry, 112 | streamEntryNeedsPaging :: Bool } 113 | 114 | binaryDeserialize :: (MonadError EventStoreActionError m, Serialize.Serialize a) => DynamoKey -> ByteString -> m a 115 | binaryDeserialize key x = do 116 | let value = Serialize.decode x 117 | case value of Left err -> throwError (EventStoreActionErrorBodyDecode key err) 118 | Right v -> return v 119 | 120 | readField :: (MonadError EventStoreActionError m) => DynamoKey -> Text -> Lens' AttributeValue (Maybe a) -> DynamoValues -> m a 121 | readField dynamoKey = 122 | readFieldGeneric (EventStoreActionErrorFieldMissing dynamoKey) 123 | 124 | valuesIsPaged :: DynamoValues -> Bool 125 | valuesIsPaged values = 126 | values & 127 | HM.member Constants.needsPagingKey & 128 | not 129 | 130 | streamEntryBodyKey :: Text 131 | streamEntryBodyKey = "Body" 132 | 133 | getStreamIdFromDynamoKey :: DynamoKey -> StreamId 134 | getStreamIdFromDynamoKey DynamoKey{..} = 135 | StreamId $ T.drop (T.length Constants.streamDynamoKeyPrefix) dynamoKeyKey 136 | 137 | dynamoReadResultToStreamEntry :: MonadError EventStoreActionError m => DynamoReadResult -> m StreamEntry 138 | dynamoReadResultToStreamEntry (DynamoReadResult key@(DynamoKey _dynamoHashKey firstEventNumber) _version values) = do 139 | eventBody <- readField key streamEntryBodyKey avB values 140 | let streamId = getStreamIdFromDynamoKey key 141 | NonEmptyWrapper eventEntries <- binaryDeserialize key eventBody 142 | let entryIsPaged = valuesIsPaged values 143 | let streamEvent = StreamEntry { 144 | streamEntryStreamId = streamId, 145 | streamEntryFirstEventNumber = firstEventNumber, 146 | streamEntryEventEntries = eventEntries, 147 | streamEntryNeedsPaging = not entryIsPaged } 148 | return streamEvent 149 | 150 | streamEntryToValues :: StreamEntry -> DynamoValues 151 | streamEntryToValues StreamEntry{..} = 152 | let 153 | bodyValue = set avB (Just ((Serialize.encode . NonEmptyWrapper) streamEntryEventEntries)) attributeValue 154 | eventCountValue = set avN (Just ((showt . length) streamEntryEventEntries)) attributeValue 155 | needsPagingValue = set avS (Just "True") attributeValue 156 | in HM.singleton streamEntryBodyKey bodyValue & 157 | HM.insert Constants.needsPagingKey needsPagingValue & 158 | HM.insert Constants.eventCountKey eventCountValue 159 | 160 | dynamoReadResultToEventNumber :: DynamoReadResult -> Int64 161 | dynamoReadResultToEventNumber (DynamoReadResult (DynamoKey _key eventNumber) _version _values) = eventNumber 162 | 163 | readStreamProducer :: (MonadEsDsl m) => QueryDirection -> StreamId -> Maybe Int64 -> Natural -> Producer DynamoReadResult m () 164 | readStreamProducer direction (StreamId streamId) startEvent batchSize = do 165 | (firstBatch :: [DynamoReadResult]) <- lift $ queryTable direction (Constants.streamDynamoKeyPrefix <> streamId) batchSize startEvent 166 | yieldResultsAndLoop firstBatch 167 | where 168 | yieldResultsAndLoop [] = return () 169 | yieldResultsAndLoop [readResult] = do 170 | yield readResult 171 | let lastEventNumber = dynamoReadResultToEventNumber readResult 172 | readStreamProducer direction (StreamId streamId) (Just lastEventNumber) batchSize 173 | yieldResultsAndLoop (x:xs) = do 174 | yield x 175 | yieldResultsAndLoop xs 176 | 177 | streamEntryProducer :: (MonadEsDsl m, MonadError EventStoreActionError m ) => QueryDirection -> StreamId -> Maybe Int64 -> Natural -> Producer StreamEntry m () 178 | streamEntryProducer direction streamId startEvent batchSize = 179 | let source = readStreamProducer direction streamId startEvent batchSize 180 | in source >-> P.mapM dynamoReadResultToStreamEntry 181 | 182 | streamEntryToDynamoKey :: StreamEntry -> DynamoKey 183 | streamEntryToDynamoKey StreamEntry { streamEntryStreamId = StreamId streamId, streamEntryFirstEventNumber = eventNumber } = 184 | DynamoKey 185 | (Constants.streamDynamoKeyPrefix <> streamId) eventNumber 186 | 187 | writeStreamItem :: (MonadEsDsl m, MonadError EventStoreActionError m) => StreamEntry -> m DynamoWriteResult 188 | writeStreamItem streamEntry@StreamEntry{..} = 189 | let values = streamEntryToValues streamEntry 190 | in dynamoWriteWithRetry (streamEntryToDynamoKey streamEntry) values 0 191 | 192 | getLastStreamItem :: (MonadEsDsl m, MonadError EventStoreActionError m) => StreamId -> m (Maybe StreamEntry) 193 | getLastStreamItem streamId = 194 | P.head $ streamEntryProducer QueryDirectionBackward streamId Nothing 1 195 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/Streams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module DynamoDbEventStore.Streams 5 | (streamEventsProducer 6 | ,globalEventKeysProducer 7 | ,globalEventsProducer 8 | ,writeEvent 9 | ,readEvent 10 | ,EventWriteResult(..)) 11 | where 12 | 13 | import DynamoDbEventStore.ProjectPrelude 14 | import Safe.Exact 15 | import Data.Foldable 16 | import DynamoDbEventStore.Types 17 | (GlobalFeedPosition(..) 18 | ,EventKey(..) 19 | ,PageKey(..) 20 | ,EventStoreActionError(..) 21 | ,FeedEntry(..) 22 | ,QueryDirection(..) 23 | ,EventId(..) 24 | ,StreamId(..) 25 | ,RecordedEvent(..) 26 | ,DynamoWriteResult(..)) 27 | import qualified DynamoDbEventStore.Storage.HeadItem as HeadItem 28 | import qualified DynamoDbEventStore.Storage.StreamItem as StreamItem 29 | import qualified DynamoDbEventStore.Storage.GlobalStreamItem as GlobalStreamItem 30 | import qualified Pipes.Prelude as P 31 | import qualified Data.List.NonEmpty as NonEmpty 32 | import qualified Data.ByteString.Lazy as BL 33 | 34 | import DynamoDbEventStore.EventStoreCommands (MonadEsDsl) 35 | import DynamoDbEventStore.Storage.StreamItem (StreamEntry(..), EventEntry(..),eventTypeToText, unEventTime,streamEntryProducer) 36 | 37 | data EventWriteResult = WriteSuccess | WrongExpectedVersion | EventExists | WriteError deriving (Eq, Show) 38 | 39 | toRecordedEvent :: (MonadEsDsl m) => StreamEntry -> m (NonEmpty RecordedEvent) 40 | toRecordedEvent StreamEntry{..} = do 41 | let eventEntriesWithEventNumber = NonEmpty.zip (streamEntryFirstEventNumber :| [streamEntryFirstEventNumber + 1 ..]) streamEntryEventEntries 42 | let (StreamId streamId) = streamEntryStreamId 43 | let buildEvent (eventNumber, EventEntry{..}) = RecordedEvent streamId eventNumber (BL.toStrict eventEntryData) (eventTypeToText eventEntryType) (unEventTime eventEntryCreated) eventEntryEventId eventEntryIsJson 44 | let recordedEvents = buildEvent <$> eventEntriesWithEventNumber 45 | return recordedEvents 46 | 47 | toRecordedEventBackward :: (MonadEsDsl m) => StreamEntry -> m (NonEmpty RecordedEvent) 48 | toRecordedEventBackward readResult = NonEmpty.reverse <$> toRecordedEvent readResult 49 | 50 | streamItemToRecordedEventPipe :: (MonadEsDsl m) => Pipe StreamEntry RecordedEvent m () 51 | streamItemToRecordedEventPipe = forever $ do 52 | streamItem <- await 53 | (recordedEvents :: NonEmpty RecordedEvent) <- lift $ toRecordedEvent streamItem 54 | forM_ (NonEmpty.toList recordedEvents) yield 55 | 56 | streamItemToRecordedEventBackwardPipe :: (MonadEsDsl m) => Pipe StreamEntry RecordedEvent m () 57 | streamItemToRecordedEventBackwardPipe = forever $ do 58 | streamItem <- await 59 | (recordedEvents :: NonEmpty RecordedEvent) <- lift $ toRecordedEventBackward streamItem 60 | forM_ (NonEmpty.toList recordedEvents) yield 61 | 62 | streamEventsProducer :: (MonadEsDsl m, MonadError EventStoreActionError m) => QueryDirection -> StreamId -> Maybe Int64 -> Natural -> Producer RecordedEvent m () 63 | streamEventsProducer QueryDirectionBackward streamId lastEvent batchSize = 64 | let 65 | maxEventToRetrieve = (+1) <$> lastEvent 66 | in 67 | streamEntryProducer QueryDirectionBackward streamId maxEventToRetrieve batchSize 68 | >-> streamItemToRecordedEventBackwardPipe 69 | >-> filterLastEvent lastEvent 70 | where 71 | filterLastEvent Nothing = P.filter (const True) 72 | filterLastEvent (Just v) = P.filter ((<= v) . recordedEventNumber) 73 | streamEventsProducer QueryDirectionForward streamId Nothing batchSize = 74 | streamEntryProducer QueryDirectionForward streamId Nothing batchSize >-> streamItemToRecordedEventPipe 75 | streamEventsProducer QueryDirectionForward streamId firstEvent batchSize = 76 | (streamEntryProducer QueryDirectionBackward streamId ((+1) <$> firstEvent) 1 >-> streamItemToRecordedEventPipe -- first page backward 77 | >> 78 | streamEntryProducer QueryDirectionForward streamId firstEvent batchSize >-> streamItemToRecordedEventPipe) -- rest of the pages 79 | >-> 80 | filterFirstEvent firstEvent 81 | where 82 | filterFirstEvent Nothing = P.filter (const True) 83 | filterFirstEvent (Just v) = P.filter ((>= v) . recordedEventNumber) 84 | 85 | getGlobalFeedBackward :: (MonadEsDsl m, MonadError EventStoreActionError m) => Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, EventKey) m () 86 | getGlobalFeedBackward Nothing = do 87 | lastKnownPage <- lift HeadItem.getLastFullPage 88 | let lastKnownPage' = fromMaybe (PageKey 0) lastKnownPage 89 | lastItem <- lift $ P.last (getPageItemsForward lastKnownPage') 90 | let lastPosition = fst <$> lastItem 91 | maybe (return ()) (getGlobalFeedBackward . Just) lastPosition 92 | getGlobalFeedBackward (Just (position@GlobalFeedPosition{..})) = 93 | getFirstPageBackward position >> getPageItemsBackward (globalFeedPositionPage - 1) 94 | 95 | getPagesBackward :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> Producer [(GlobalFeedPosition,EventKey)] m () 96 | getPagesBackward (PageKey (-1)) = return () 97 | getPagesBackward page = do 98 | result <- lift $ GlobalStreamItem.readPage page 99 | _ <- case result of (Just entries) -> yield (globalFeedItemToEventKeys entries) 100 | Nothing -> lift $ throwError (EventStoreActionErrorInvalidGlobalFeedPage page) 101 | getPagesBackward (page - 1) 102 | 103 | globalFeedItemToEventKeys :: GlobalStreamItem.GlobalFeedItem -> [(GlobalFeedPosition, EventKey)] 104 | globalFeedItemToEventKeys GlobalStreamItem.GlobalFeedItem{..} = 105 | let eventKeys = join $ feedEntryToEventKeys <$> toList globalFeedItemFeedEntries 106 | in zip (GlobalFeedPosition globalFeedItemPageKey <$> [0..]) eventKeys 107 | 108 | globalEventKeysProducer :: (MonadEsDsl m, MonadError EventStoreActionError m) => QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, EventKey) m () 109 | globalEventKeysProducer QueryDirectionBackward startPosition = 110 | getGlobalFeedBackward startPosition 111 | globalEventKeysProducer QueryDirectionForward startPosition = 112 | let 113 | startPage = fromMaybe 0 (globalFeedPositionPage <$> startPosition) 114 | in 115 | getPageItemsForward startPage 116 | >-> filterFirstEvent startPosition 117 | where 118 | filterFirstEvent Nothing = P.filter (const True) 119 | filterFirstEvent (Just position) = P.filter ((> position) . fst) 120 | 121 | lookupEvent :: (MonadEsDsl m, MonadError EventStoreActionError m) => StreamId -> Int64 -> m (Maybe RecordedEvent) 122 | lookupEvent streamId eventNumber = 123 | P.head $ 124 | streamEventsProducer QueryDirectionBackward streamId (Just eventNumber) 1 125 | >-> 126 | P.dropWhile ((/= eventNumber). recordedEventNumber) 127 | 128 | lookupEventKey :: (MonadEsDsl m, MonadError EventStoreActionError m) => Pipe (GlobalFeedPosition, EventKey) (GlobalFeedPosition, RecordedEvent) m () 129 | lookupEventKey = forever $ do 130 | (position, eventKey@(EventKey(streamId, eventNumber))) <- await 131 | (maybeRecordedEvent :: Maybe RecordedEvent) <- lift $ lookupEvent streamId eventNumber 132 | let withPosition = (\e -> (position, e)) <$> maybeRecordedEvent 133 | maybe (throwError $ EventStoreActionErrorCouldNotFindEvent eventKey) yield withPosition 134 | 135 | globalEventsProducer :: (MonadEsDsl m, MonadError EventStoreActionError m) => QueryDirection -> Maybe GlobalFeedPosition -> Producer (GlobalFeedPosition, RecordedEvent) m () 136 | globalEventsProducer direction startPosition = 137 | globalEventKeysProducer direction startPosition 138 | >-> lookupEventKey 139 | 140 | feedEntryToEventKeys :: FeedEntry -> [EventKey] 141 | feedEntryToEventKeys FeedEntry { feedEntryStream = streamId, feedEntryNumber = eventNumber, feedEntryCount = entryCount } = 142 | (\number -> EventKey(streamId, number)) <$> take entryCount [eventNumber..] 143 | 144 | getPageItemsBackward :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> Producer (GlobalFeedPosition, EventKey) m () 145 | getPageItemsBackward startPage = 146 | getPagesBackward startPage >-> readResultToEventKeys 147 | where 148 | readResultToEventKeys = forever $ 149 | (reverse <$> await) >>= mapM_ yield 150 | 151 | getFirstPageBackward :: (MonadEsDsl m, MonadError EventStoreActionError m) => GlobalFeedPosition -> Producer (GlobalFeedPosition, EventKey) m () 152 | getFirstPageBackward position@GlobalFeedPosition{..} = do 153 | items <- lift $ GlobalStreamItem.readPage globalFeedPositionPage 154 | let itemsBeforePosition = (globalFeedItemToEventKeys <$> items) >>= takeExactMay (globalFeedPositionOffset + 1) 155 | maybe notFoundError yieldItemsInReverse itemsBeforePosition 156 | where 157 | notFoundError = lift $ throwError (EventStoreActionErrorInvalidGlobalFeedPosition position) 158 | yieldItemsInReverse = mapM_ yield . reverse 159 | 160 | getPagesForward :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> Producer [(GlobalFeedPosition,EventKey)] m () 161 | getPagesForward startPage = do 162 | result <- lift $ GlobalStreamItem.readPage startPage 163 | case result of (Just entries) -> yield (globalFeedItemToEventKeys entries) >> getPagesForward (startPage + 1) 164 | Nothing -> return () 165 | 166 | getPageItemsForward :: (MonadEsDsl m, MonadError EventStoreActionError m) => PageKey -> Producer (GlobalFeedPosition, EventKey) m () 167 | getPageItemsForward startPage = 168 | getPagesForward startPage >-> readResultToEventKeys 169 | where 170 | readResultToEventKeys = forever $ 171 | await >>= mapM_ yield 172 | 173 | ensureExpectedVersion :: (MonadEsDsl m, MonadError EventStoreActionError m) => StreamId -> Int64 -> m Bool 174 | ensureExpectedVersion _streamId (-1) = return True 175 | ensureExpectedVersion _streamId 0 = return True 176 | ensureExpectedVersion streamId expectedEventNumber = 177 | checkEventNumber <$> StreamItem.getLastStreamItem streamId 178 | where 179 | checkEventNumber Nothing = False 180 | checkEventNumber (Just StreamEntry {..}) = 181 | let lastEventNumber = streamEntryFirstEventNumber + fromIntegral (length streamEntryEventEntries) - 1 182 | in lastEventNumber == expectedEventNumber 183 | 184 | readEvent :: (MonadEsDsl m, MonadError EventStoreActionError m) => StreamId -> Int64 -> m (Maybe RecordedEvent) 185 | readEvent streamId eventNumber = do 186 | P.head $ 187 | streamEventsProducer QueryDirectionBackward streamId (Just eventNumber) 1 188 | 189 | writeEvent :: (MonadEsDsl m, MonadError EventStoreActionError m) => StreamId -> Maybe Int64 -> NonEmpty EventEntry -> m EventWriteResult 190 | writeEvent (StreamId sId) ev eventEntries = do 191 | let eventId = (eventEntryEventId . NonEmpty.head) eventEntries 192 | dynamoKeyOrError <- getDynamoKey sId ev eventId 193 | case dynamoKeyOrError of Left a -> return a 194 | Right dynamoKey -> writeMyEvent dynamoKey 195 | where 196 | writeMyEvent :: (MonadEsDsl m, MonadError EventStoreActionError m) => Int64 -> m EventWriteResult 197 | writeMyEvent eventNumber = do 198 | let streamEntry = StreamEntry { 199 | streamEntryStreamId = StreamId sId, 200 | streamEntryFirstEventNumber = eventNumber, 201 | streamEntryEventEntries = eventEntries, 202 | streamEntryNeedsPaging = True } 203 | writeResult <- StreamItem.writeStreamItem streamEntry 204 | return $ toEventResult writeResult 205 | getDynamoKey :: (MonadEsDsl m, MonadError EventStoreActionError m) => Text -> Maybe Int64 -> EventId -> m (Either EventWriteResult Int64) 206 | getDynamoKey streamId Nothing eventId = do 207 | lastEvent <- P.head $ streamEventsProducer QueryDirectionBackward (StreamId streamId) Nothing 1 208 | let lastEventNumber = maybe (-1) recordedEventNumber lastEvent 209 | let lastEventIdIsNotTheSame = maybe True ((/= eventId) . recordedEventId) lastEvent 210 | if lastEventIdIsNotTheSame then 211 | let eventVersion = lastEventNumber + 1 212 | in return . Right $ eventVersion 213 | else return $ Left WriteSuccess 214 | getDynamoKey streamId (Just expectedVersion) _eventId = do 215 | expectedVersionOk <- ensureExpectedVersion (StreamId streamId) expectedVersion 216 | if expectedVersionOk then do 217 | let eventVersion = expectedVersion + 1 218 | return . Right $ eventVersion 219 | else 220 | return $ Left WrongExpectedVersion 221 | toEventResult :: DynamoWriteResult -> EventWriteResult 222 | toEventResult DynamoWriteSuccess = WriteSuccess 223 | toEventResult DynamoWriteFailure = WriteError 224 | toEventResult DynamoWriteWrongVersion = EventExists 225 | -------------------------------------------------------------------------------- /dynamodb-eventstore/src/DynamoDbEventStore/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | module DynamoDbEventStore.Types 7 | (DynamoKey(..) 8 | , DynamoValues 9 | , DynamoReadResult(..) 10 | , DynamoWriteResult (..) 11 | , DynamoVersion 12 | , LogLevel(..) 13 | , QueryDirection(..) 14 | , StreamId(..) 15 | , PageKey(..) 16 | , FeedEntry(..) 17 | , RecordedEvent(..) 18 | , EventId(..) 19 | , EventKey(..) 20 | , EventStoreActionError(..) 21 | , GlobalFeedPosition(..) 22 | , ValueUpdate(..)) 23 | where 24 | 25 | import BasicPrelude 26 | import Data.Aeson 27 | import qualified Data.HashMap.Strict as HM 28 | import qualified Data.Serialize as Serialize 29 | import Data.Time.Clock 30 | import qualified Data.UUID as UUID 31 | import GHC.Generics 32 | import Network.AWS.DynamoDB 33 | import qualified Test.QuickCheck as QC 34 | import TextShow.TH 35 | 36 | data DynamoKey = DynamoKey { 37 | dynamoKeyKey :: Text, 38 | dynamoKeyEventNumber :: Int64 39 | } deriving (Show, Eq) 40 | 41 | instance Ord DynamoKey where 42 | compare dynamoKey1 dynamoKey2 = 43 | let 44 | eventNumberCompare = compare (dynamoKeyEventNumber dynamoKey1) (dynamoKeyEventNumber dynamoKey2) 45 | keyKeyCompare = compare (dynamoKeyKey dynamoKey1) (dynamoKeyKey dynamoKey2) 46 | in case eventNumberCompare of EQ -> keyKeyCompare 47 | x -> x 48 | 49 | 50 | type DynamoValues = HM.HashMap Text AttributeValue 51 | data DynamoReadResult = DynamoReadResult { 52 | dynamoReadResultKey :: DynamoKey, 53 | dynamoReadResultVersion :: Int, 54 | dynamoReadResultValue :: DynamoValues 55 | } deriving (Show, Eq) 56 | 57 | type DynamoVersion = Int 58 | 59 | data DynamoWriteResult = 60 | DynamoWriteSuccess | 61 | DynamoWriteFailure | 62 | DynamoWriteWrongVersion deriving (Eq, Show) 63 | 64 | data LogLevel = 65 | Debug | 66 | Info | 67 | Warn | 68 | Error 69 | deriving (Eq, Show) 70 | 71 | data ValueUpdate = 72 | ValueUpdateSet AttributeValue 73 | | ValueUpdateDelete 74 | 75 | data QueryDirection = 76 | QueryDirectionForward 77 | | QueryDirectionBackward 78 | deriving (Show, Eq) 79 | 80 | newtype StreamId = StreamId { unStreamId :: Text } deriving (Ord, Eq, Show, Hashable) 81 | deriveTextShow ''StreamId 82 | 83 | instance QC.Arbitrary StreamId where 84 | arbitrary = StreamId . fromString <$> QC.arbitrary 85 | 86 | newtype PageKey = PageKey { unPageKey :: Int64 } deriving (Ord, Eq, Num, Enum) 87 | 88 | instance QC.Arbitrary PageKey where 89 | arbitrary = 90 | let 91 | positiveToPageKey (QC.Positive p) = PageKey p 92 | in positiveToPageKey <$> QC.arbitrary 93 | 94 | instance Show PageKey where 95 | showsPrec precendence (PageKey p) = showsPrec precendence p 96 | 97 | data FeedEntry = FeedEntry { 98 | feedEntryStream :: StreamId, 99 | feedEntryNumber :: Int64, 100 | feedEntryCount :: Int 101 | } deriving (Eq, Show, Ord) 102 | 103 | instance QC.Arbitrary FeedEntry where 104 | arbitrary = 105 | FeedEntry <$> QC.arbitrary 106 | <*> QC.arbitrary 107 | <*> QC.arbitrary 108 | 109 | instance FromJSON StreamId where 110 | parseJSON (String v) = 111 | return $ StreamId v 112 | parseJSON _ = mzero 113 | instance ToJSON StreamId where 114 | toJSON (StreamId streamId) = 115 | String streamId 116 | 117 | instance FromJSON FeedEntry where 118 | parseJSON (Object v) = FeedEntry <$> 119 | v .: "s" <*> 120 | v .: "n" <*> 121 | v .: "c" 122 | parseJSON _ = mempty 123 | 124 | instance ToJSON FeedEntry where 125 | toJSON (FeedEntry stream number entryCount) = 126 | object ["s" .= stream, "n" .= number, "c" .=entryCount] 127 | 128 | newtype EventKey = EventKey (StreamId, Int64) deriving (Ord, Eq, Show) 129 | deriveTextShow ''EventKey 130 | data PageStatus = Version Int | Full | Verified deriving (Eq, Show, Generic) 131 | 132 | newtype EventId = EventId { unEventId :: UUID.UUID } deriving (Show, Eq, Ord, Generic) 133 | 134 | instance Serialize.Serialize EventId where 135 | put (EventId uuid) = do 136 | let (w0, w1, w2, w3) = UUID.toWords uuid 137 | Serialize.put w0 138 | Serialize.put w1 139 | Serialize.put w2 140 | Serialize.put w3 141 | get = EventId <$> do 142 | w0 <- Serialize.get 143 | w1 <- Serialize.get 144 | w2 <- Serialize.get 145 | w3 <- Serialize.get 146 | return $ UUID.fromWords w0 w1 w2 w3 147 | 148 | instance QC.Arbitrary EventId where 149 | arbitrary = 150 | EventId 151 | <$> (UUID.fromWords 152 | <$> QC.arbitrary 153 | <*> QC.arbitrary 154 | <*> QC.arbitrary 155 | <*> QC.arbitrary) 156 | 157 | data RecordedEvent = RecordedEvent { 158 | recordedEventStreamId :: Text, 159 | recordedEventNumber :: Int64, 160 | recordedEventData :: ByteString, 161 | recordedEventType :: Text, 162 | recordedEventCreated :: UTCTime, 163 | recordedEventId :: EventId, 164 | recordedEventIsJson :: Bool 165 | } deriving (Show, Eq, Ord) 166 | 167 | instance ToJSON RecordedEvent where 168 | toJSON RecordedEvent{..} = 169 | object [ "streamId" .= recordedEventStreamId 170 | , "eventNumber" .= recordedEventNumber 171 | , "eventData" .= decodeUtf8 recordedEventData 172 | , "eventType" .= recordedEventType 173 | ] 174 | 175 | instance FromJSON PageStatus 176 | instance ToJSON PageStatus 177 | 178 | instance FromJSON EventKey where 179 | parseJSON (Object v) = 180 | EventKey <$> 181 | ((,) <$> v .: "streamId" 182 | <*> v .: "eventNumber") 183 | parseJSON _ = mzero 184 | instance ToJSON EventKey where 185 | toJSON (EventKey(streamId, eventNumber)) = 186 | object [ "streamId" .= streamId 187 | , "eventNumber" .= eventNumber 188 | ] 189 | 190 | data EventStoreActionError = 191 | EventStoreActionErrorFieldMissing DynamoKey Text | 192 | EventStoreActionErrorCouldNotReadEventCount (Maybe Text) | 193 | EventStoreActionErrorJsonDecodeError String | 194 | EventStoreActionErrorBodyDecode DynamoKey String | 195 | EventStoreActionErrorEventDoesNotExist DynamoKey | 196 | EventStoreActionErrorOnWritingPage PageKey | 197 | EventStoreActionErrorPageDoesNotExist PageKey | 198 | EventstoreActionErrorCouldNotFindPreviousEntry DynamoKey | 199 | EventStoreActionErrorCouldNotFindEvent EventKey | 200 | EventStoreActionErrorInvalidGlobalFeedPosition GlobalFeedPosition | 201 | EventStoreActionErrorInvalidGlobalFeedPage PageKey | 202 | EventStoreActionErrorWriteFailure DynamoKey | 203 | EventStoreActionErrorUpdateFailure DynamoKey | 204 | EventStoreActionErrorHeadFieldMissing Text | 205 | EventStoreActionErrorHeadFieldFormat Text Text | 206 | EventStoreActionErrorPageStatusFieldFormat Text 207 | deriving (Show, Eq, Typeable) 208 | 209 | instance Exception EventStoreActionError 210 | 211 | data GlobalFeedPosition = GlobalFeedPosition { 212 | globalFeedPositionPage :: PageKey 213 | , globalFeedPositionOffset :: Int 214 | } deriving (Show, Eq, Ord) 215 | 216 | instance QC.Arbitrary GlobalFeedPosition where 217 | arbitrary = GlobalFeedPosition 218 | <$> QC.arbitrary 219 | <*> ((\(QC.Positive p) -> p) <$> QC.arbitrary) 220 | -------------------------------------------------------------------------------- /dynamodb-eventstore/tests/DynamoCmdAmazonkaTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module DynamoCmdAmazonkaTests where 6 | 7 | import BasicPrelude 8 | import Control.Lens 9 | import qualified Data.HashMap.Lazy as HM 10 | import qualified Data.Sequence as Seq 11 | import DynamoDbEventStore.AmazonkaImplementation (InterpreterError) 12 | import qualified DynamoDbEventStore.Constants as Constants 13 | import DynamoDbEventStore.EventStoreCommands 14 | import Network.AWS.DynamoDB hiding (updateItem) 15 | import Test.Tasty 16 | import Test.Tasty.HUnit 17 | 18 | testStreamId :: Text 19 | testStreamId = "Brownie" 20 | 21 | testKey :: DynamoKey 22 | testKey = DynamoKey testStreamId 0 23 | 24 | sampleValuesNeedsPaging :: DynamoValues 25 | sampleValuesNeedsPaging = 26 | HM.singleton "Body" (set avS (Just "Andrew") attributeValue) & 27 | HM.insert Constants.needsPagingKey (set avS (Just "True") attributeValue) 28 | 29 | sampleValuesNoPaging :: DynamoValues 30 | sampleValuesNoPaging = 31 | HM.singleton "Body" (set avS (Just "Andrew") attributeValue) 32 | 33 | testWrite 34 | :: MonadEsDsl m 35 | => DynamoValues -> DynamoVersion -> m DynamoWriteResult 36 | testWrite = writeToDynamo testKey 37 | 38 | sampleRead 39 | :: MonadEsDsl m 40 | => m (Maybe DynamoReadResult) 41 | sampleRead = readFromDynamo testKey 42 | 43 | waitForItem 44 | :: (MonadEsDslWithFork m, Typeable a) 45 | => QueueType m a -> m a 46 | waitForItem q = go Nothing 47 | where 48 | go Nothing = tryReadQueue q >>= go 49 | go (Just x) = return x 50 | 51 | tests 52 | :: MonadEsDslWithFork m 53 | => (forall a. m a -> IO (Either InterpreterError a)) -> [TestTree] 54 | tests evalProgram = 55 | [ testCase "Can spawn a new thread" $ 56 | let queueItem = (PageKey 1, Seq.fromList ['a']) 57 | childThread 58 | :: MonadEsDsl m 59 | => QueueType m (PageKey, Seq Char) -> m () 60 | childThread q = do 61 | writeQueue q queueItem 62 | actions = do 63 | q <- newQueue 64 | forkChild "childThread" (childThread q) 65 | waitForItem q 66 | evt = evalProgram actions 67 | expected = Right queueItem 68 | in do r <- evt 69 | assertEqual "Queue item is read back" expected r 70 | , testCase "Can write and read to complete page queue" $ 71 | let queueItem = (PageKey 1, Seq.fromList ['a']) 72 | actions = do 73 | q <- newQueue 74 | writeQueue q queueItem >> tryReadQueue q 75 | evt = evalProgram actions 76 | expected = Right . Just $ queueItem 77 | in do r <- evt 78 | assertEqual "Queue item is read back" expected r 79 | , testCase "Can read from cache" $ 80 | let actions = do 81 | c <- newCache 10 82 | cacheInsert c 'a' 'b' 83 | cacheLookup c 'a' 84 | result = evalProgram actions 85 | expected = Right . Just $ 'b' 86 | in do r <- result 87 | assertEqual "Cache item is read back" expected r 88 | , testCase "Can read event" $ 89 | let actions = do 90 | _ <- testWrite sampleValuesNeedsPaging 0 91 | sampleRead 92 | evt = evalProgram actions 93 | expected = 94 | Right $ Just $ DynamoReadResult testKey 0 sampleValuesNeedsPaging 95 | in do r <- evt 96 | assertEqual "Event is read" expected r 97 | , testCase "Write event returns WriteExists when event already exists" $ 98 | let actions = do 99 | _ <- testWrite sampleValuesNeedsPaging 0 100 | testWrite sampleValuesNeedsPaging 0 -- duplicate 101 | writeResult = evalProgram actions 102 | in do r <- writeResult 103 | assertEqual 104 | "Second write has error" 105 | (Right DynamoWriteWrongVersion) 106 | r 107 | , testCase "Update set field adds the field" $ 108 | let myKeyValue = set avS (Just "testValue") attributeValue 109 | actions = do 110 | _ <- testWrite sampleValuesNoPaging 0 111 | _ <- 112 | updateItem 113 | testKey 114 | (HM.singleton "MyKey" (ValueUpdateSet myKeyValue)) 115 | sampleRead 116 | readResult = evalProgram actions 117 | in do r <- readResult 118 | let myKey = (HM.lookup "MyKey" . dynamoReadResultValue <$>) <$> r 119 | assertEqual 120 | "MyKey as value: testValue" 121 | (Right . Just . Just $ myKeyValue) 122 | myKey 123 | , testCase "Delete field removes the field" $ 124 | let actions = do 125 | _ <- testWrite sampleValuesNeedsPaging 0 126 | _ <- 127 | updateItem 128 | testKey 129 | (HM.singleton Constants.needsPagingKey ValueUpdateDelete) 130 | sampleRead 131 | readResult = evalProgram actions 132 | in do r <- readResult 133 | let needsPagingKey = 134 | (HM.lookup Constants.needsPagingKey . dynamoReadResultValue <$>) <$> 135 | r 136 | assertEqual 137 | "NeedsPaging has been deleted" 138 | (Right . Just $ Nothing) 139 | needsPagingKey 140 | , testCase "With correct version you can write a subsequent event" $ 141 | let actions = do 142 | _ <- testWrite sampleValuesNeedsPaging 0 143 | testWrite sampleValuesNeedsPaging 1 144 | writeResult = evalProgram actions 145 | in do r <- writeResult 146 | assertEqual 147 | "Second write should succeed" 148 | (Right DynamoWriteSuccess) 149 | r 150 | , testCase "Scan unpaged events returns written event" $ 151 | let actions = do 152 | _ <- testWrite sampleValuesNeedsPaging 0 153 | scanNeedsPaging 154 | evtList = evalProgram actions 155 | in do r <- evtList 156 | assertEqual "Should should have single item" (Right [testKey]) r 157 | , testCase "Scan unpaged events does not returned paged event" $ 158 | let actions = do 159 | _ <- testWrite sampleValuesNeedsPaging 0 160 | _ <- testWrite sampleValuesNoPaging 1 161 | scanNeedsPaging 162 | evtList = evalProgram actions 163 | in do r <- evtList 164 | assertEqual "Should have no items" (Right []) r 165 | , testCase "Can read events backward" $ 166 | let actions = do 167 | _ <- 168 | writeToDynamo 169 | (DynamoKey testStreamId 0) 170 | sampleValuesNeedsPaging 171 | 0 172 | _ <- 173 | writeToDynamo 174 | (DynamoKey testStreamId 1) 175 | sampleValuesNeedsPaging 176 | 0 177 | queryTable QueryDirectionBackward testStreamId 10 Nothing 178 | evt = evalProgram actions 179 | expected = 180 | Right 181 | [ DynamoReadResult 182 | (DynamoKey testStreamId 1) 183 | 0 184 | sampleValuesNeedsPaging 185 | , DynamoReadResult 186 | (DynamoKey testStreamId 0) 187 | 0 188 | sampleValuesNeedsPaging] 189 | in do r <- evt 190 | assertEqual "Events are returned in reverse order" expected r 191 | , testCase "Read events respects max items " $ 192 | let actions = do 193 | _ <- 194 | writeToDynamo 195 | (DynamoKey testStreamId 0) 196 | sampleValuesNeedsPaging 197 | 0 198 | _ <- 199 | writeToDynamo 200 | (DynamoKey testStreamId 1) 201 | sampleValuesNeedsPaging 202 | 0 203 | queryTable QueryDirectionBackward testStreamId 1 Nothing 204 | evt = evalProgram actions 205 | expected = 206 | Right 207 | [ DynamoReadResult 208 | (DynamoKey testStreamId 1) 209 | 0 210 | sampleValuesNeedsPaging] 211 | in do r <- evt 212 | assertEqual "Only event 1 should be returned" expected r 213 | , testCase "Can read events backward starting at offset" $ 214 | let actions = do 215 | _ <- 216 | writeToDynamo 217 | (DynamoKey testStreamId 0) 218 | sampleValuesNeedsPaging 219 | 0 220 | _ <- 221 | writeToDynamo 222 | (DynamoKey testStreamId 1) 223 | sampleValuesNeedsPaging 224 | 0 225 | queryTable QueryDirectionBackward testStreamId 10 (Just 1) 226 | evt = evalProgram actions 227 | expected = 228 | Right 229 | [ DynamoReadResult 230 | (DynamoKey testStreamId 0) 231 | 0 232 | sampleValuesNeedsPaging] 233 | in do r <- evt 234 | assertEqual "Only the 0th event is returned" expected r 235 | , testCase "Can read events forward starting at offset" $ 236 | let actions = do 237 | _ <- 238 | writeToDynamo 239 | (DynamoKey testStreamId 0) 240 | sampleValuesNeedsPaging 241 | 0 242 | _ <- 243 | writeToDynamo 244 | (DynamoKey testStreamId 1) 245 | sampleValuesNeedsPaging 246 | 0 247 | queryTable QueryDirectionForward testStreamId 10 (Just 0) 248 | evt = evalProgram actions 249 | expected = 250 | Right 251 | [ DynamoReadResult 252 | (DynamoKey testStreamId 1) 253 | 0 254 | sampleValuesNeedsPaging] 255 | in do r <- evt 256 | assertEqual "Only the 1st event is returned" expected r] 257 | -------------------------------------------------------------------------------- /dynamodb-eventstore/tests/DynamoDbEventStore/InMemoryCache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module DynamoDbEventStore.InMemoryCache 4 | (newCache 5 | ,emptyCache 6 | ,insertCache 7 | ,lookupCache 8 | ,Cache(..) 9 | ,Caches) where 10 | 11 | import BasicPrelude 12 | import qualified Data.Cache.LRU as LRU 13 | import Data.Dynamic 14 | import qualified Data.Map.Strict as Map 15 | import Safe 16 | 17 | data Caches = Caches 18 | { cachesNextIndex :: Int 19 | , cachesCacheMap :: Map Int (Integer, Maybe Dynamic) 20 | } deriving ((Show)) 21 | 22 | emptyCache :: Caches 23 | emptyCache = 24 | Caches 25 | { 26 | cachesNextIndex = 0 27 | , cachesCacheMap = mempty 28 | } 29 | 30 | newtype Cache k v = Cache 31 | { unCache :: Int 32 | } deriving ((Show)) 33 | 34 | newCache :: Integer -> Caches -> (Cache k v, Caches) 35 | newCache size Caches{..} = 36 | let cacheKey = 37 | Cache 38 | { unCache = cachesNextIndex 39 | } 40 | caches = 41 | Caches 42 | { cachesNextIndex = cachesNextIndex + 1 43 | , cachesCacheMap = Map.insert 44 | cachesNextIndex 45 | (size, Nothing) 46 | cachesCacheMap 47 | } 48 | in (cacheKey, caches) 49 | 50 | insertCache 51 | :: (Typeable k, Ord k, Typeable v) 52 | => Cache k v -> k -> v -> Caches -> Caches 53 | insertCache Cache{..} key value caches@Caches{..} = 54 | let cache = fromJustNote "insert: could not find cache" $ Map.lookup unCache cachesCacheMap 55 | updatedCache = insertItem cache 56 | in caches 57 | { cachesCacheMap = Map.insert unCache updatedCache cachesCacheMap 58 | } 59 | where 60 | insertItem (size, Nothing) = 61 | let cache = LRU.insert key value (LRU.newLRU (Just size)) 62 | in (size, Just (toDyn cache)) 63 | insertItem (size,Just dyn) = 64 | let 65 | cache = 66 | fromDyn 67 | dyn 68 | (error 69 | "InMemoryCaches.insertCache Invalid format for cache") 70 | cache' = LRU.insert key value cache 71 | in (size, Just (toDyn cache')) 72 | 73 | lookupCache 74 | :: (Typeable k, Ord k, Typeable v) 75 | => Cache k v -> k -> Caches -> (Maybe v, Caches) 76 | lookupCache Cache{..} key caches@Caches{..} = 77 | let (size, cache) = fromJustNote "insert: could not find cache" $ Map.lookup unCache cachesCacheMap 78 | (cache', result) = go cache 79 | in ( result, 80 | caches 81 | { cachesCacheMap = Map.insert unCache (size, cache') cachesCacheMap }) 82 | where 83 | go Nothing = (Nothing, Nothing) 84 | go (Just dyn) = 85 | let 86 | cache = 87 | fromDyn 88 | dyn 89 | (error 90 | "InMemoryCaches.lookupCache Invalid format for cache") 91 | (cache', result) = LRU.lookup key cache 92 | in (Just (toDyn cache'), result) 93 | -------------------------------------------------------------------------------- /dynamodb-eventstore/tests/DynamoDbEventStore/InMemoryDynamoTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module DynamoDbEventStore.InMemoryDynamoTable 5 | (InMemoryDynamoTable 6 | , emptyDynamoTable 7 | , readDb 8 | , writeDb 9 | , updateDb 10 | , queryDb 11 | , scanNeedsPagingDb 12 | ) where 13 | 14 | import BasicPrelude 15 | import Control.Lens 16 | import qualified Data.HashMap.Strict as HM 17 | import qualified Data.Map.Strict as Map 18 | import qualified Data.Set as Set 19 | import qualified DynamoDbEventStore.Constants as Constants 20 | import DynamoDbEventStore.EventStoreCommands 21 | import GHC.Natural 22 | 23 | data InMemoryDynamoTable = InMemoryDynamoTable { 24 | _inMemoryDynamoTableTable :: HM.HashMap Text (Map Int64 (Int, DynamoValues)) 25 | , _inMemoryDynamoTableNeedsPaging :: Set DynamoKey } 26 | deriving (Eq, Show) 27 | 28 | $(makeLenses ''InMemoryDynamoTable) 29 | 30 | emptyDynamoTable :: InMemoryDynamoTable 31 | emptyDynamoTable = InMemoryDynamoTable { 32 | _inMemoryDynamoTableTable = mempty 33 | , _inMemoryDynamoTableNeedsPaging = mempty} 34 | 35 | readDb :: DynamoKey -> InMemoryDynamoTable -> Maybe DynamoReadResult 36 | readDb key@DynamoKey{..} db = 37 | let 38 | entry = db ^. 39 | (inMemoryDynamoTableTable 40 | . at dynamoKeyKey 41 | . non mempty 42 | . at dynamoKeyEventNumber) 43 | buildReadResult (version, value) = DynamoReadResult { 44 | dynamoReadResultKey = key 45 | , dynamoReadResultVersion = version 46 | , dynamoReadResultValue = value } 47 | in buildReadResult <$> entry 48 | 49 | updateDb :: DynamoKey -> HashMap Text ValueUpdate -> InMemoryDynamoTable -> InMemoryDynamoTable 50 | updateDb key@DynamoKey{..} updates db = 51 | let 52 | entryLocation = 53 | inMemoryDynamoTableTable 54 | . at dynamoKeyKey . non mempty 55 | . at dynamoKeyEventNumber 56 | . _Just 57 | . _2 58 | in over entryLocation setValues db & over inMemoryDynamoTableNeedsPaging updatePagingTable 59 | where 60 | updatePagingTable = 61 | case HM.lookup Constants.needsPagingKey updates of 62 | Nothing -> id 63 | (Just (ValueUpdateSet _)) -> Set.insert key 64 | (Just ValueUpdateDelete) -> Set.delete key 65 | setValues :: DynamoValues -> DynamoValues 66 | setValues initialValues = HM.foldrWithKey applyUpdate initialValues updates 67 | applyUpdate :: Text -> ValueUpdate -> DynamoValues -> DynamoValues 68 | applyUpdate k (ValueUpdateSet attribute) = HM.insert k attribute 69 | applyUpdate k ValueUpdateDelete = HM.delete k 70 | 71 | writeDb :: DynamoKey -> DynamoValues -> DynamoVersion -> InMemoryDynamoTable -> (DynamoWriteResult, InMemoryDynamoTable) 72 | writeDb key@DynamoKey{..} values version db = 73 | let 74 | entryLocation = 75 | inMemoryDynamoTableTable 76 | . at dynamoKeyKey . non mempty 77 | . at dynamoKeyEventNumber 78 | currentVersion = fst <$> db ^. entryLocation 79 | in writeVersion version currentVersion 80 | where 81 | entryNeedsPaging = HM.member Constants.needsPagingKey values 82 | writeVersion 0 Nothing = performWrite 0 83 | writeVersion _newVersion Nothing = (DynamoWriteWrongVersion, db) 84 | writeVersion newVersion (Just currentVersion) 85 | | currentVersion == newVersion - 1 = performWrite newVersion 86 | | otherwise = (DynamoWriteWrongVersion, db) 87 | updatePagingTable = 88 | if entryNeedsPaging then 89 | Set.insert key 90 | else 91 | Set.delete key 92 | performWrite newVersion = 93 | let 94 | newEntry = (newVersion, values) 95 | entryLocation = 96 | inMemoryDynamoTableTable 97 | . at dynamoKeyKey . non mempty 98 | . at dynamoKeyEventNumber 99 | db' = set entryLocation (Just newEntry) db 100 | & over inMemoryDynamoTableNeedsPaging updatePagingTable 101 | in (DynamoWriteSuccess, db') 102 | 103 | queryDb :: QueryDirection -> Text -> Natural -> Maybe Int64 -> InMemoryDynamoTable -> [DynamoReadResult] 104 | queryDb direction streamId maxEvents startEvent db = 105 | let 106 | rangeItems = db ^. inMemoryDynamoTableTable . at streamId . non mempty 107 | items = case (direction, startEvent) of 108 | (QueryDirectionForward, Nothing) -> Map.toAscList rangeItems 109 | (QueryDirectionForward, Just startEventNumber) -> 110 | rangeItems 111 | & Map.split startEventNumber 112 | & snd 113 | & Map.toAscList 114 | (QueryDirectionBackward, Nothing) -> Map.toDescList rangeItems 115 | (QueryDirectionBackward, Just startEventNumber) -> 116 | rangeItems 117 | & Map.split startEventNumber 118 | & fst 119 | & Map.toDescList 120 | itemsCutOff = take (fromIntegral maxEvents) items 121 | toReadResult (eventNumber, (currentVersion, value)) = DynamoReadResult { 122 | dynamoReadResultKey = DynamoKey streamId eventNumber 123 | , dynamoReadResultVersion = currentVersion 124 | , dynamoReadResultValue = value } 125 | in toReadResult <$> itemsCutOff 126 | 127 | scanNeedsPagingDb :: InMemoryDynamoTable -> [DynamoKey] 128 | scanNeedsPagingDb = view $ inMemoryDynamoTableNeedsPaging . to Set.toAscList 129 | -------------------------------------------------------------------------------- /dynamodb-eventstore/tests/tastytests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import BasicPrelude 6 | import qualified DynamoCmdAmazonkaTests 7 | import qualified DynamoDbEventStore.AmazonkaImplementation as Ai 8 | import qualified DynamoDbEventStore.DynamoCmdInterpreter as TestInterpreter 9 | import DynamoDbEventStore.GlobalFeedWriterSpec as GlobalFeedWriterSpec 10 | 11 | import System.Metrics hiding (Value) 12 | import Test.Tasty 13 | import DodgerBlue.Testing 14 | 15 | 16 | testInterpreter :: TestInterpreter.DynamoCmdM Queue a -> IO (Either Ai.InterpreterError a) 17 | testInterpreter program = 18 | return $ Right $ TestInterpreter.evalProgram "Test Program" program TestInterpreter.emptyTestState 19 | 20 | nullMetrics :: IO Ai.MetricLogs 21 | nullMetrics = do 22 | store <- newStore 23 | return Ai.MetricLogs { 24 | Ai.metricLogsReadItem = doNothingPair, 25 | Ai.metricLogsWriteItem = doNothingPair, 26 | Ai.metricLogsUpdateItem = doNothingPair, 27 | Ai.metricLogsQuery = doNothingPair, 28 | Ai.metricLogsScan = doNothingPair, 29 | Ai.metricLogsStore = store } 30 | where 31 | doNothingPair = Ai.MetricLogsPair { 32 | Ai.metricLogsPairCount = return (), 33 | Ai.metricLogsPairTimeMs = const $ return () } 34 | 35 | main :: IO () 36 | main = do 37 | nullMetricsForAi <- nullMetrics 38 | defaultMain $ 39 | testGroup "Tests" 40 | [ testGroup "DynamoCmd Tests against Dynamo - Amazonka" (DynamoCmdAmazonkaTests.tests (Ai.evalProgram nullMetricsForAi)), 41 | testGroup "DynamoCmd Tests against Test Interpreter" (DynamoCmdAmazonkaTests.tests testInterpreter), 42 | testGroup "Global Feed Writer" GlobalFeedWriterSpec.tests 43 | ] 44 | -------------------------------------------------------------------------------- /example-commands.txt: -------------------------------------------------------------------------------- 1 | post event: 2 | ensure es-eventid is unique 3 | curl -i -d @event.json "http://127.0.0.1:2113/streams/newstream" -H "Content-Type:application/json" -H "ES-EventType: blah" -H "ES-EventId: facecc99-944a-45b9-a1f2-e45d5bc636b9" 4 | 5 | read stream: 6 | curl -i http://127.0.0.1:2114/streams/newstream 7 | 8 | read all events: 9 | 10 | -------------------------------------------------------------------------------- /scripts/run-dynamodb-local.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | SCRIPT_DIR=$( cd "$( dirname "$0" )" && pwd ) 4 | DYNAMO_LOCAL_TARBALL="http://dynamodb-local.s3-website-us-west-2.amazonaws.com/dynamodb_local_latest.tar.gz" 5 | DYNAMO_DESTINATION="$SCRIPT_DIR/dynamodb_local_latest" 6 | 7 | echo $DYNAMO_DESTINATION 8 | if [ ! -d "$DYNAMO_DESTINATION" ]; then 9 | mkdir $DYNAMO_DESTINATION 10 | curl -L $DYNAMO_LOCAL_TARBALL | tar xz -C "$DYNAMO_DESTINATION/" 11 | fi 12 | 13 | DYNAMO_LIB_PATH="$DYNAMO_DESTINATION/DynamoDBLocal_lib" 14 | DYNAMO_JAR_PATH="$DYNAMO_DESTINATION/DynamoDBLocal.jar" 15 | 16 | java -Djava.library.path=$DYNAMO_LIB_PATH -jar $DYNAMO_JAR_PATH -sharedDb 17 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - 'dynamodb-eventstore' 4 | - 'dynamodb-eventstore-web' 5 | - 'dynamodb-eventstore-client' 6 | - location: 7 | git: https://github.com/adbrowne/dodgerblue.git 8 | commit: a42db6d59f385bba0a4ae5dbf60b8aa1f4a9d6b4 9 | extra-dep: true 10 | - location: 11 | git: https://github.com/adbrowne/aeson-diff.git 12 | commit: efbc512745bc624dc9666ff6dc37a570b7a66b99 13 | extra-dep: true 14 | resolver: lts-8.0 15 | extra-deps: 16 | - aeson-diff-1.1.0.0 17 | - edit-distance-vector-1.0.0.4 18 | - wreq-0.5.0.0 19 | --------------------------------------------------------------------------------