packages feed

eventful-dynamodb (empty) → 0.1.0

raw patch · 8 files changed

+451/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +aeson

Dependencies added: HUnit, QuickCheck, aeson, amazonka, amazonka-dynamodb, base, bytestring, conduit, eventful-core, eventful-test-helpers, hlint, hspec, lens, quickcheck-instances, safe, text, unordered-containers, vector

Files

+ LICENSE.md view
@@ -0,0 +1,19 @@+Copyright (c) 2016-2017 David Reaver++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ eventful-dynamodb.cabal view
@@ -0,0 +1,99 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name:           eventful-dynamodb+version:        0.1.0+synopsis:       Library for eventful DynamoDB event stores+description:    Library for eventful DynamoDB event stores+category:       Database,Eventsourcing,AWS+stability:      experimental+maintainer:     David Reaver+license:        MIT+license-file:   LICENSE.md+build-type:     Simple+cabal-version:  >= 1.10++library+  hs-source-dirs:+      src+  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , eventful-core+    , aeson+    , amazonka+    , amazonka-dynamodb+    , bytestring+    , conduit+    , lens+    , safe+    , text+    , unordered-containers+    , vector+  exposed-modules:+      Eventful.Store.DynamoDB+      Eventful.Store.DynamoDB.DynamoJSON+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      tests+      src+  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , eventful-core+    , aeson+    , amazonka+    , amazonka-dynamodb+    , bytestring+    , conduit+    , lens+    , safe+    , text+    , unordered-containers+    , vector+    , hspec+    , HUnit+    , QuickCheck+    , quickcheck-instances+    , eventful-test-helpers+  other-modules:+      Eventful.Store.DynamoDB.DynamoJSONSpec+      Eventful.Store.DynamoDBSpec+      HLint+      Eventful.Store.DynamoDB+      Eventful.Store.DynamoDB.DynamoJSON+  default-language: Haskell2010++test-suite style+  type: exitcode-stdio-1.0+  main-is: HLint.hs+  hs-source-dirs:+      tests+  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , eventful-core+    , aeson+    , amazonka+    , amazonka-dynamodb+    , bytestring+    , conduit+    , lens+    , safe+    , text+    , unordered-containers+    , vector+    , hlint+  other-modules:+      Eventful.Store.DynamoDB.DynamoJSONSpec+      Eventful.Store.DynamoDBSpec+      Spec+  default-language: Haskell2010
+ src/Eventful/Store/DynamoDB.hs view
@@ -0,0 +1,214 @@+module Eventful.Store.DynamoDB+  ( dynamoDBEventStore+  , DynamoDBEventStoreConfig (..)+  , defaultDynamoDBEventStoreConfig+  , initializeDynamoDBEventStore+  , deleteDynamoDBEventStoreTable+  , runAWSIO+  ) where++import Eventful++import Control.Exception (throw, toException)+import Control.Lens+import Control.Monad (forM_, unless, void, when)+import Control.Monad.Trans.AWS (runAWST)+import Data.Aeson+import Data.Conduit (($$), (=$=))+import qualified Data.Conduit.List as CL+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Network.AWS+import Network.AWS.DynamoDB+import Safe+import System.IO++import Eventful.Store.DynamoDB.DynamoJSON++data DynamoDBEventStoreConfig serialized =+  DynamoDBEventStoreConfig+  { dynamoDBEventStoreConfigTableName :: Text+  , dynamoDBEventStoreConfigUUIDAttributeName :: Text+  , dynamoDBEventStoreConfigVersionAttributeName :: Text+  , dynamoDBEventStoreConfigEventAttributeName :: Text+  , dynamoDBEventStoreConfigSerializedToValue :: serialized -> AttributeValue+  , dynamoDBEventStoreConfigValueToSerialized :: AttributeValue -> serialized+  }++defaultDynamoDBEventStoreConfig :: DynamoDBEventStoreConfig Value+defaultDynamoDBEventStoreConfig =+  DynamoDBEventStoreConfig+  { dynamoDBEventStoreConfigTableName = "Events"+  , dynamoDBEventStoreConfigUUIDAttributeName = "UUID"+  , dynamoDBEventStoreConfigVersionAttributeName = "Version"+  , dynamoDBEventStoreConfigEventAttributeName = "Event"+  , dynamoDBEventStoreConfigSerializedToValue = valueToAttributeValue+  , dynamoDBEventStoreConfigValueToSerialized = attributeValueToValue+  }++-- | An 'EventStore' that uses AWS DynamoDB as the storage backend. Use a+-- 'DynamoDBEventStoreConfig' to configure this event store.+dynamoDBEventStore+  :: DynamoDBEventStoreConfig serialized+  -> EventStore serialized AWS+dynamoDBEventStore config =+  let+    getLatestVersion = latestEventVersion config+    getEvents = getDynamoEvents config+    storeEvents' = storeDynamoEvents config+    storeEvents = transactionalExpectedWriteHelper getLatestVersion storeEvents'+  in EventStore{..}++getDynamoEvents+  :: (MonadAWS m)+  => DynamoDBEventStoreConfig serialized+  -> UUID+  -> Maybe EventVersion+  -> m [StoredEvent serialized]+getDynamoEvents config@DynamoDBEventStoreConfig{..} uuid mStartingVersion = do+  latestEvents <-+    paginate (queryBase config uuid mStartingVersion) =$=+    CL.concatMap (view qrsItems) $$+    CL.consume+  return $ mapMaybe (decodeDynamoEvent config uuid) latestEvents++decodeDynamoEvent+  :: DynamoDBEventStoreConfig serialized+  -> UUID+  -> HashMap Text AttributeValue+  -> Maybe (StoredEvent serialized)+decodeDynamoEvent DynamoDBEventStoreConfig{..} uuid attributeMap = do+  versionValue <- HM.lookup dynamoDBEventStoreConfigVersionAttributeName attributeMap+  versionText <- versionValue ^. avN+  version <- EventVersion <$> readMay (T.unpack versionText)+  eventAttributeValue <- HM.lookup dynamoDBEventStoreConfigEventAttributeName attributeMap+  let event = dynamoDBEventStoreConfigValueToSerialized eventAttributeValue+  return $ StoredEvent uuid version event++latestEventVersion+  :: (MonadAWS m)+  => DynamoDBEventStoreConfig serialized+  -> UUID+  -> m EventVersion+latestEventVersion config@DynamoDBEventStoreConfig{..} uuid = do+  latestEvents <- fmap (view qrsItems) . send $+    queryBase config uuid Nothing+    & qLimit ?~ 1+    & qScanIndexForward ?~ False+  return $ EventVersion $ fromMaybe (-1) $ do+    -- NB: We are in the Maybe monad here+    attributeMap <- headMay latestEvents+    versionValue <- HM.lookup dynamoDBEventStoreConfigVersionAttributeName attributeMap+    version <- versionValue ^. avN+    readMay $ T.unpack version++-- | Convenience function to create a Query value for a given store config and+-- UUID.+queryBase+  :: DynamoDBEventStoreConfig serialized+  -> UUID+  -> Maybe EventVersion+  -> Query+queryBase DynamoDBEventStoreConfig{..} uuid mStartingVersion =+  query+  dynamoDBEventStoreConfigTableName+  & qKeyConditionExpression ?~ "#uuid = :uuid" <> versionCaseExpression+  & qExpressionAttributeNames .~+    HM.singleton "#uuid" dynamoDBEventStoreConfigUUIDAttributeName <>+    versionVariableName+  & qExpressionAttributeValues .~+    HM.singleton ":uuid" (attributeValue & avS ?~ uuidToText uuid) <>+    versionAttributeValue+  where+    versionCaseExpression = maybe "" (const " AND #version >= :version") mStartingVersion+    versionVariableName = maybe HM.empty (const $ HM.singleton "#version" dynamoDBEventStoreConfigVersionAttributeName) mStartingVersion+    versionAttributeValue = maybe HM.empty (HM.singleton ":version" . mkVersionValue) mStartingVersion+    mkVersionValue (EventVersion version) = attributeValue & avN ?~ T.pack (show version)++storeDynamoEvents+  :: (MonadAWS m)+  => DynamoDBEventStoreConfig serialized+  -> UUID+  -> [serialized]+  -> m ()+storeDynamoEvents config@DynamoDBEventStoreConfig{..} uuid events = do+  latestVersion <- latestEventVersion config uuid++  -- TODO: Use BatchWriteItem+  forM_ (zip events [latestVersion + 1..]) $ \(event, EventVersion version) ->+    send $+      putItem+      dynamoDBEventStoreConfigTableName+      & piItem .~+        HM.fromList+        [ (dynamoDBEventStoreConfigUUIDAttributeName, attributeValue & avS ?~ uuidToText uuid)+        , (dynamoDBEventStoreConfigVersionAttributeName, attributeValue & avN ?~ T.pack (show version))+        , (dynamoDBEventStoreConfigEventAttributeName, dynamoDBEventStoreConfigSerializedToValue event)+        ]++-- | Helpful function to create the events table. If a table already exists+-- with the same name, then this function just uses that one. Note, there are+-- no magic migrations going on here, trust this function at your own risk.+initializeDynamoDBEventStore+  :: (MonadAWS m)+  => DynamoDBEventStoreConfig serialized+  -> ProvisionedThroughput+  -> m ()+initializeDynamoDBEventStore config@DynamoDBEventStoreConfig{..} throughput = do+  eventTableExists <- getDynamoDBEventStoreTableExistence config+  unless eventTableExists $ do+    void $ send $+      createTable+      dynamoDBEventStoreConfigTableName+      (uuidKey :| [versionKey])+      throughput+      & ctAttributeDefinitions .~ attributeDefs+    void $ await tableExists (describeTable dynamoDBEventStoreConfigTableName)+  where+    uuidKey = keySchemaElement dynamoDBEventStoreConfigUUIDAttributeName Hash+    versionKey = keySchemaElement dynamoDBEventStoreConfigVersionAttributeName Range+    attributeDefs =+      [ attributeDefinition dynamoDBEventStoreConfigUUIDAttributeName S+      , attributeDefinition dynamoDBEventStoreConfigVersionAttributeName N+      ]++-- | Checks if the table for the event store exists.+getDynamoDBEventStoreTableExistence+  :: (MonadAWS m)+  => DynamoDBEventStoreConfig serialized+  -> m Bool+getDynamoDBEventStoreTableExistence DynamoDBEventStoreConfig{..} = do+  tablesResponse <- trying _ServiceError $ send $+    describeTable+    dynamoDBEventStoreConfigTableName+  case tablesResponse of+    Right response' -> return $ isJust (response' ^. drsTable)+    Left err ->+      if err ^. serviceCode == ErrorCode "ResourceNotFound"+      then return False+      else throw $ toException (ServiceError err)++-- | Convenience function to drop the event store table. Mainly used for+-- testing this library.+deleteDynamoDBEventStoreTable+  :: (MonadAWS m)+  => DynamoDBEventStoreConfig serialized+  -> m ()+deleteDynamoDBEventStoreTable config@DynamoDBEventStoreConfig{..} = do+  eventTableExists <- getDynamoDBEventStoreTableExistence config+  when eventTableExists $ do+    void $ send $ deleteTable dynamoDBEventStoreConfigTableName+    void $ await tableNotExists (describeTable dynamoDBEventStoreConfigTableName)++-- | Convenience function if you don't really care about your amazonka+-- settings.+runAWSIO :: AWS a -> IO a+runAWSIO action = do+  lgr <- newLogger Trace stdout+  env <- newEnv Discover <&> set envLogger lgr+  runResourceT . runAWST env $ action
+ src/Eventful/Store/DynamoDB/DynamoJSON.hs view
@@ -0,0 +1,37 @@+module Eventful.Store.DynamoDB.DynamoJSON+  ( valueToAttributeValue+  , attributeValueToValue+  ) where++import Control.Lens+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Vector as V+import Network.AWS.DynamoDB hiding (Null)++-- | Note, currently we can't properly disambiguate between an empty Object or+-- an empty Array because of amazonka's 'AttributeValue' lenses. We use a very+-- nasty kludge where we replace empty Objects with a string with a very+-- special value. Follow this issue to see when we can remove the kludge:+-- https://github.com/brendanhay/amazonka/issues/282.+valueToAttributeValue :: Value -> AttributeValue+valueToAttributeValue (String v) = attributeValue & avS ?~ v+valueToAttributeValue (Number v) = attributeValue & avN ?~ T.pack (show v)+valueToAttributeValue (Bool v) = attributeValue & avBOOL ?~ v+valueToAttributeValue (Array vs) = attributeValue & avL .~ fmap valueToAttributeValue (V.toList vs)+valueToAttributeValue (Object v)+  | HM.null v = attributeValue & avS ?~ "__eventful-dynamodb-empty-object__"+  | otherwise = attributeValue & avM .~ fmap valueToAttributeValue v+valueToAttributeValue Null = attributeValue & avNULL ?~ True++attributeValueToValue :: AttributeValue -> Value+attributeValueToValue av+  | Just "__eventful-dynamodb-empty-object__" <- av ^. avS = Object HM.empty+  | Just v <- av ^. avS = String v+  | Just v <- av ^. avN = Number $ read $ T.unpack v+  | Just v <- av ^. avBOOL = Bool v+  | Just _ <- av ^. avNULL = Null+  | v <- av ^. avM, not (HM.null v) = Object $ fmap attributeValueToValue v+  | vs <- av ^. avL = Array $ V.fromList $ fmap attributeValueToValue vs+  | otherwise = Null
+ tests/Eventful/Store/DynamoDB/DynamoJSONSpec.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Eventful.Store.DynamoDB.DynamoJSONSpec (spec) where++import Data.Aeson+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances ()++import Eventful.Store.DynamoDB.DynamoJSON++spec :: Spec+spec = do+  describe "Value <-> AttributeValue conversion" $ do+    it "Value -> AttributeValue -> Value round trip is idempotent" $ property $+      \value -> attributeValueToValue (valueToAttributeValue value) == value++instance Arbitrary Value where+  arbitrary = sized sizedArbitraryValue++sizedArbitraryValue :: Int -> Gen Value+sizedArbitraryValue n+  | n <= 0 = oneof [pure Null, bool, number, string]+  | otherwise = resize n' $ oneof [pure Null, bool, number, string, array, object']+  where+    n' = n `div` 2+    bool = Bool <$> arbitrary+    number = Number <$> arbitrary+    string = String <$> arbitrary+    array = Array <$> arbitrary+    object' = Object <$> arbitrary
+ tests/Eventful/Store/DynamoDBSpec.hs view
@@ -0,0 +1,31 @@+module Eventful.Store.DynamoDBSpec (spec) where++import Control.Lens ((<&>))+import Network.AWS+import Network.AWS.DynamoDB+import Test.Hspec++import Eventful+import Eventful.Store.DynamoDB+import Eventful.TestHelpers++makeStore :: IO (EventStore CounterEvent AWS, Env)+makeStore = do+  let+    dynamo = setEndpoint False "localhost" 8000 dynamoDB+  env <- newEnv Discover <&> configure dynamo++  let+    store = dynamoDBEventStore defaultDynamoDBEventStoreConfig+    store' = serializedEventStore jsonSerializer store+  liftIO $ runResourceT . runAWS env $ do+    -- Delete and recreate table+    deleteDynamoDBEventStoreTable defaultDynamoDBEventStoreConfig+    initializeDynamoDBEventStore defaultDynamoDBEventStoreConfig (provisionedThroughput 1 1)++  return (store', env)++spec :: Spec+spec = do+  describe "DynamoDB event store" $ do+    eventStoreSpec makeStore (\env action -> runResourceT $ runAWS env action)
+ tests/HLint.hs view
@@ -0,0 +1,19 @@+module Main (main) where++import Language.Haskell.HLint (hlint)+import System.Exit (exitFailure, exitSuccess)++import Prelude (String, IO, null)++arguments :: [String]+arguments =+  [ "src"+  , "tests"+  , "-i=Redundant do"+  , "-i=Unused LANGUAGE pragma" -- This fails on DeriveGeneric+  ]++main :: IO ()+main = do+    hints <- hlint arguments+    if null hints then exitSuccess else exitFailure
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}