dynamodb-simple (empty) → 0.1.0.0
raw patch · 17 files changed
+3075/−0 lines, 17 filesdep +aesondep +amazonkadep +amazonka-coresetup-changed
Dependencies added: aeson, amazonka, amazonka-core, amazonka-dynamodb, base, bytestring, conduit, containers, double-conversion, dynamodb-simple, exceptions, generics-sop, hashable, hspec, lens, monad-loops, monad-supply, safe-exceptions, scientific, semigroups, tagged, template-haskell, text, transformers, unordered-containers, vector
Files
- LICENSE +30/−0
- README.md +97/−0
- Setup.hs +2/−0
- dynamodb-simple.cabal +50/−0
- src/Database/DynamoDB.hs +277/−0
- src/Database/DynamoDB/BatchRequest.hs +125/−0
- src/Database/DynamoDB/Class.hs +339/−0
- src/Database/DynamoDB/Filter.hs +127/−0
- src/Database/DynamoDB/Internal.hs +220/−0
- src/Database/DynamoDB/Migration.hs +279/−0
- src/Database/DynamoDB/QueryRequest.hs +287/−0
- src/Database/DynamoDB/TH.hs +375/−0
- src/Database/DynamoDB/Types.hs +299/−0
- src/Database/DynamoDB/Update.hs +210/−0
- test/BaseSpec.hs +209/−0
- test/NestedSpec.hs +148/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Ondrej Palkovsky++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ondrej Palkovsky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,97 @@+# DynamoDB layer for Haskell++[](https://travis-ci.org/ondrap/dynamodb-simple) [](https://hackage.haskell.org/package/dynamodb-simple)++This library intends to simplify working with DynamoDB AWS database.+It uses Generics code ([generics-sop](https://hackage.haskell.org/package/generics-sop)) on top of your structures+and just by adding a few instances allows you to easily generate AWS+commands.++````haskell+data Test = Test {+ category :: T.Text+ , user :: T.Text+ , subject :: T.Text+ , replies :: Int+} deriving (Show)+-- Generate instances and colCategory, colUser etc. variables for queries/updates+mkTableDefs "migrate" (tableConfig (''Test, WithRange) [] [])++test :: IO ()+test = do+ lgr <- newLogger Info stdout+ setEnv "AWS_ACCESS_KEY_ID" "XXXXXXXXXXXXXX"+ setEnv "AWS_SECRET_ACCESS_KEY" "XXXXXXXXXXXXXXfdjdsfjdsfjdskldfs+kl"+ env <- newEnv Discover+ let dynamo = setEndpoint False "localhost" 8000 dynamoDB+ let newenv = env & configure dynamo & set envLogger lgr+ runResourceT $ runAWS newenv $ do+ migrate mempty Nothing -- Create tables, indices etc.+ --+ putItem (Test "news" "john" "test" 20)+ --+ (item :: Maybe Test) <- getItem Eventually ("news", "john")+ liftIO $ print item+ --+ (items :: [Test]) <- scanCond (colReplies >. 15) 10+ liftIO $ print items+````+### Features++- Global secondary indexes.+- Local secondary indexes.+- Tables with only hash keys as well as tables with combined hash and sort key.+- Sparse indexes (define the column as `Maybe` in a table, omit the `Maybe` in index definition).+- Standard datatypes including `Tagged` and basic default instances for data types supporting+ `Show/Read`.+- New types can be added easily.+- High-level, easy-to-use API - hides intricacies of both DynamoDB and amazonka library.+- Type-safe conditions, including nested structures.+- Type-safe update actions.+- Template-haskell macro to easily create all relevant instances.+- 'Schema migration' - upon startup checks if the database schema matches the definition+ and, if possible, adjusts the database. If it is impossible, it fails.+- Automatic handling of invalid values (empty strings, empty sets). Automatic rewriting of+ queries when searching for these empty values.+- Compatible with GHC8 `DuplicateRecordFields`+- Customizable table and index names. Custom translation of field names to attribute names.+- Streaming settings.++### What is planned++- Support for automatic versioning of fields.++### Limitations++- Projections are not supported. Using some generic programming on tuples it should be possible.+- You cannot compare attributes between themselves (i.e. `colCurrentAccount >=. colAverageAccount`).+ I'm not sure this would be currently technically possible. Does anybody need it?++### Handling of NULLs++DynamoDB does not accept empty strings/sets. It accepts `NULL`, but that is not acceptable+in fields that are used for sparse indexing.++Empty string and empty set are represented by omitting the value.++* `Just Nothing :: Maybe (Maybe a)` will become `Nothing` on retrieval.+* `[Just 1, Nothing, Just 3]` will become `[Just 1, Just 3]` on retrieval.+* `HashMap Text (Maybe a)` is not a good idea; missing values will disappear.+* `Maybe (Set a)` will become `Nothing` on empty set+* Don't try to use inequality comparisons (`>.`, `<.`) on empty strings.+* If you use `colMaybeCol == Nothing`, it gets internally replaced+ by `attr_missing(colMaybeCol)`, so it will behave as expected. The same with+ empty `String` or `Set`. Keep that in mind when traversing nested structures.+* In case of schema change, `Maybe` columns are considered `Nothing`.+* In case of schema change, `String` columns are decoded as empty strings, `Set` columns+ as empty sets, `[a]` columns as empty lists.+* Condition for `== ""`, `== []` etc. is automatically enhanced to account for non-existent attributes+ (i.e. after schema change).+* Empty list/empty hashmap is represented as empty list/hashmap; however it is allowed to be decoded+ even when the attribute is missing in order to allow better schema migrations.++### Notes++There is a bug in `amazonka-dynamodb` that causes the `Conduit`-based queries/scans not behave correctly+under certain circumstances. It's also why the travis CI build of dynamodb-simple is failing+right now.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dynamodb-simple.cabal view
@@ -0,0 +1,50 @@+name: dynamodb-simple+version: 0.1.0.0+synopsis: Typesafe library for working with DynamoDB database+description: Framework for accessing DynamoDB database. The majority of AWS API+ is available to the user in a convenient, simple and typesafe manner.+license: BSD3+license-file: LICENSE+author: Ondrej Palkovsky+maintainer: palkovsky.ondrej@gmail.com+copyright: Ondrej Palkovsky+homepage: https://github.com/ondrap/dynamodb-simple+bug-reports: https://github.com/ondrap/dynamodb-simple/issues+category: Database+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/ondrap/dynamodb-simple.git++library+ exposed-modules: Database.DynamoDB, Database.DynamoDB.Types,+ Database.DynamoDB.Filter, Database.DynamoDB.TH,+ Database.DynamoDB.Update+ other-modules: Database.DynamoDB.Class, Database.DynamoDB.Migration,+ Database.DynamoDB.Internal, Database.DynamoDB.BatchRequest,+ Database.DynamoDB.QueryRequest+ build-depends: base >=4.8 && <5, amazonka-dynamodb, generics-sop,+ unordered-containers, text, lens, double-conversion,+ semigroups, bytestring, containers, monad-supply,+ template-haskell, transformers, exceptions,+ amazonka, monad-loops, conduit, hashable,+ amazonka-core, aeson, vector, scientific,+ tagged+ -- hspec, safe-exceptions+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-incomplete-uni-patterns++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: BaseSpec, NestedSpec+ build-depends: base, dynamodb-simple, hspec, text, lens, transformers,+ safe-exceptions, amazonka-dynamodb >= 1.4.5, amazonka, conduit,+ semigroups, hashable, containers, unordered-containers,+ tagged+ default-language: Haskell2010+ hs-source-dirs: test
+ src/Database/DynamoDB.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Data.DynamoDb+-- License : BSD-style+--+-- Maintainer : palkovsky.ondrej@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Type-safe library for accessing DynamoDB database.+--+module Database.DynamoDB (+ -- * Introduction+ -- $intro++ -- * Data types+ DynamoException(..)+ , Consistency(..)+ , Direction(..)+ , Column+ -- * Attribute path combinators+ , (<.>), (<!>), (<!:>)+ -- * Fetching items+ , getItem+ , getItemBatch+ -- * Query options+ , QueryOpts+ , queryOpts+ , qConsistentRead, qStartKey, qDirection, qFilterCondition, qHashKey, qRangeCondition, qLimit+ -- * Performing query+ , query+ , querySimple+ , queryCond+ , querySource+ -- * Scan options+ , ScanOpts+ , scanOpts+ , sFilterCondition, sConsistentRead, sLimit, sParallel, sStartKey+ -- * Performing scan+ , scan+ , scanSource+ , scanCond+ -- * Data entry+ , putItem+ , putItemBatch+ , insertItem+ -- * Data modification+ , updateItemByKey+ , updateItemByKey_+ , updateItemCond_+ -- * Deleting data+ , deleteItemByKey+ , deleteItemCondByKey+ , deleteItemBatchByKey+ -- * Delete table+ , deleteTable+ -- * Utility functions+ , itemToKey+) where++import Control.Lens ((%~), (.~), (^.))+import Control.Monad (void)+import Control.Monad.Catch (throwM)+import Data.Bool (bool)+import Data.Function ((&))+import Data.Proxy+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Generics.SOP+import Network.AWS+import qualified Network.AWS.DynamoDB.DeleteItem as D+import qualified Network.AWS.DynamoDB.GetItem as D+import qualified Network.AWS.DynamoDB.PutItem as D+import qualified Network.AWS.DynamoDB.UpdateItem as D+import qualified Network.AWS.DynamoDB.DeleteTable as D+import qualified Network.AWS.DynamoDB.Types as D++import Database.DynamoDB.Class+import Database.DynamoDB.Filter+import Database.DynamoDB.Internal+import Database.DynamoDB.Types+import Database.DynamoDB.Update+import Database.DynamoDB.BatchRequest+import Database.DynamoDB.QueryRequest+++dDeleteItem :: (DynamoTable a r, HasPrimaryKey a r 'IsTable, Code a ~ '[ hash ': range ': xss ])+ => Proxy a -> PrimaryKey (Code a) r -> D.DeleteItem+dDeleteItem p pkey = D.deleteItem (tableName p) & D.diKey .~ dKeyToAttr p pkey++dGetItem :: (DynamoTable a r, HasPrimaryKey a r 'IsTable, Code a ~ '[ hash ': range ': xss ])+ => Proxy a -> PrimaryKey (Code a) r -> D.GetItem+dGetItem p pkey = D.getItem (tableName p) & D.giKey .~ dKeyToAttr p pkey++-- | Write item into the database; overwrite any previously existing item with the same primary key.+putItem :: (MonadAWS m, DynamoTable a r) => a -> m ()+putItem item = void $ send (dPutItem item)++-- | Write item into the database only if it doesn't already exist.+insertItem :: forall a r m. (MonadAWS m, DynamoTable a r) => a -> m ()+insertItem item = do+ let keyfields = primaryFields (Proxy :: Proxy a)+ -- Create condition attribute_not_exist(hash_key)+ pkeyMissing = (AttrMissing . nameGenPath . pure . IntraName) $ head keyfields+ (expr, attnames, attvals) = dumpCondition pkeyMissing+ cmd = dPutItem item & D.piExpressionAttributeNames .~ attnames+ & D.piConditionExpression .~ Just expr+ & bool (D.piExpressionAttributeValues .~ attvals) id (null attvals) -- HACK; https://github.com/brendanhay/amazonka/issues/332+ void $ send cmd+++-- | Read item from the database; primary key is either a hash key or (hash,range) tuple depending on the table.+getItem :: forall m a r range hash rest.+ (MonadAWS m, DynamoTable a r, HasPrimaryKey a r 'IsTable, Code a ~ '[ hash ': range ': rest])+ => Consistency -> PrimaryKey (Code a) r -> m (Maybe a)+getItem consistency key = do+ let cmd = dGetItem (Proxy :: Proxy a) key & D.giConsistentRead . consistencyL .~ consistency+ rs <- send cmd+ let result = rs ^. D.girsItem+ if | null result -> return Nothing+ | otherwise ->+ case gsDecode result of+ Just res -> return (Just res)+ Nothing -> throwM (DynamoException $ "Cannot decode item: " <> T.pack (show result))++-- | Delete item from the database by specifying the primary key.+deleteItemByKey :: forall m a r hash range rest.+ (MonadAWS m, HasPrimaryKey a r 'IsTable, DynamoTable a r, Code a ~ '[ hash ': range ': rest])+ => (Proxy a, PrimaryKey (Code a) r) -> m ()+deleteItemByKey (p, pkey) = void $ send (dDeleteItem p pkey)++-- | Delete item from the database by specifying the primary key and a condition.+-- Throws AWS exception if the condition does not succeed.+deleteItemCondByKey :: forall m a r hash range rest.+ (MonadAWS m, HasPrimaryKey a r 'IsTable, DynamoTable a r, Code a ~ '[ hash ': range ': rest])+ => (Proxy a, PrimaryKey (Code a) r) -> FilterCondition a -> m ()+deleteItemCondByKey (p, pkey) cond =+ let (expr, attnames, attvals) = dumpCondition cond+ cmd = dDeleteItem p pkey & D.diExpressionAttributeNames .~ attnames+ & bool (D.diExpressionAttributeValues .~ attvals) id (null attvals) -- HACK; https://github.com/brendanhay/amazonka/issues/332+ & D.diConditionExpression .~ Just expr+ in void (send cmd)++-- | Generate update item object; automatically adds condition for existence of primary+-- key, so that only existing objects are modified+dUpdateItem :: forall a r hash range xss.+ (DynamoTable a r, HasPrimaryKey a r 'IsTable, Code a ~ '[ hash ': range ': xss ])+ => Proxy a -> PrimaryKey (Code a) r -> Action a -> Maybe (FilterCondition a) -> Maybe D.UpdateItem+dUpdateItem p pkey actions mcond =+ genAction <$> dumpActions actions+ where+ keyfields = primaryFields (Proxy :: Proxy a)+ -- Create condition attribute_exists(hash_key)+ pkeyExists = (AttrExists . nameGenPath . pure . IntraName) (head keyfields)++ genAction actparams =+ D.updateItem (tableName p) & D.uiKey .~ dKeyToAttr p pkey+ & addActions actparams+ & addCondition (Just pkeyExists <> mcond)++ addActions (expr, attnames, attvals) =+ (D.uiUpdateExpression .~ Just expr)+ . (D.uiExpressionAttributeNames %~ (<> attnames))+ . bool (D.uiExpressionAttributeValues %~ (<> attvals)) id (null attvals)+ addCondition (Just cond) =+ let (expr, attnames, attvals) = dumpCondition cond+ in (D.uiConditionExpression .~ Just expr)+ . (D.uiExpressionAttributeNames %~ (<> attnames))+ . bool (D.uiExpressionAttributeValues %~ (<> attvals)) id (null attvals) -- HACK; https://github.com/brendanhay/amazonka/issues/332+ addCondition Nothing = id -- Cannot happen anyway+++-- | Update item in a table+--+-- > updateItem (Proxy :: Proxy Test) (12, "2") [colCount +=. 100]+updateItemByKey_ :: forall a m r hash range rest.+ (MonadAWS m, HasPrimaryKey a r 'IsTable, DynamoTable a r, Code a ~ '[ hash ': range ': rest ])+ => (Proxy a, PrimaryKey (Code a) r) -> Action a -> m ()+updateItemByKey_ (p, pkey) actions+ | Just cmd <- dUpdateItem p pkey actions Nothing = void $ send cmd+ | otherwise = return ()++updateItemByKey :: forall a m r hash range rest.+ (MonadAWS m, HasPrimaryKey a r 'IsTable, DynamoTable a r, Code a ~ '[ hash ': range ': rest ])+ => (Proxy a, PrimaryKey (Code a) r) -> Action a -> m a+updateItemByKey (p, pkey) actions+ | Just cmd <- dUpdateItem p pkey actions Nothing = do+ rs <- send (cmd & D.uiReturnValues .~ Just D.AllNew)+ case gsDecode (rs ^. D.uirsAttributes) of+ Just res -> return res+ Nothing -> throwM (DynamoException $ "Cannot decode item: " <> T.pack (show rs))+ | otherwise = do+ rs <- getItem Strongly pkey+ case rs of+ Just res -> return res+ Nothing -> throwM (DynamoException "Cannot decode item.")++-- | Update item in a table while specifying a condition+updateItemCond_ :: forall a m r hash range rest.+ (MonadAWS m, DynamoTable a r, HasPrimaryKey a r 'IsTable, Code a ~ '[ hash ': range ': rest ])+ => (Proxy a, PrimaryKey (Code a) r) -> Action a -> FilterCondition a -> m ()+updateItemCond_ (p, pkey) actions cond+ | Just cmd <- dUpdateItem p pkey actions (Just cond) = void $ send cmd+ | otherwise = return ()++-- | Delete table from DynamoDB.+deleteTable :: (MonadAWS m, DynamoTable a r) => Proxy a -> m ()+deleteTable p = void $ send (D.deleteTable (tableName p))++-- | Extract primary key from a record in a form that can be directly used by other functions.+--+-- TODO: this should be callable on index structures containing primary key as well+itemToKey :: (HasPrimaryKey a r t, Code a ~ '[hash ': range ': xss]) => a -> (Proxy a, PrimaryKey (Code a) r)+itemToKey a = (Proxy, dItemToKey a)++-- $intro+--+-- This library is operated in the following way:+--+-- * Create instances for your custom types using "Database.DynamoDB.Types"+-- * Create ordinary datatypes with records+-- * Use functions from "Database.DynamoDB.TH" to derive appropriate instances+-- * Optionally call generated migration function to automatically create+-- tables and indices+-- * Call functions from this module to access the database+--+-- The library does its best to ensure that only correct DynamoDB+-- operations are allowed. There are some limitations of DynamoDB+-- regarding access to empty values, but the library takes care+-- of this reasonably well.+--+-- Example of use+--+-- You may need to set AWS_ACCESS_KEY_ID and AWS_SECRET_ACCESS_KEY environment+-- variables.+--+-- @+-- data Test = Test {+-- category :: T.Text+-- , messageid :: T.Text+-- , subject :: T.Text+-- } deriving (Show)+-- mkTableDefs "migrate" (tableConfig (''Test, WithRange) [] [])+-- @+--+-- This code creates appropriate instances for the table and the columns. It creates+-- global variables `colCategory`, `colMessageid` and `colSubject` that can be used+-- in filtering conditions or update queries.+--+-- @+-- main = do+-- lgr <- newLogger Info stdout+-- env <- newEnv NorthVirginia Discover+-- -- Override, use DynamoDD on localhost+-- let dynamo = setEndpoint False "localhost" 8000 dynamoDB+-- let newenv = env & configure dynamo+-- & set envLogger lgr+-- runResourceT $ runAWS newenv $ do+-- -- Create tables and indexes+-- migrate mempty Nothing+-- -- Save data to database+-- putItem (Test "news" "1-2-3-4" "New subject")+-- -- Fetch data given primary key+-- (item :: Maybe Test) <- getItem Eventually ("news", "1-2-3-4")+-- liftIO $ print item+-- -- Scan data using filter condition, return 10 results+-- (items :: [Test]) <- scanCond (colSubject ==. "New subejct") 10+-- @+--+-- See examples/ and test/ directories for more detail examples.
+ src/Database/DynamoDB/BatchRequest.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Database.DynamoDB.BatchRequest (+ putItemBatch+ , getItemBatch+ , deleteItemBatchByKey+) where++import Control.Concurrent (threadDelay)+import Control.Lens (at, ix, (.~), (^.), (^..))+import Control.Monad (unless)+import Control.Monad.Catch (throwM)+import Control.Monad.IO.Class (liftIO)+import Data.Function ((&))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid ((<>))+import Data.Proxy+import qualified Data.Text as T+import Generics.SOP+import Network.AWS+import qualified Network.AWS.DynamoDB.BatchGetItem as D+import qualified Network.AWS.DynamoDB.BatchWriteItem as D+import qualified Network.AWS.DynamoDB.Types as D++import Database.DynamoDB.Class+import Database.DynamoDB.Internal+import Database.DynamoDB.Types++++-- | Retry batch operation, until unprocessedItems is empty.+--+-- TODO: we should use exponential backoff; currently we use a simple 1-sec threadDelay+retryWriteBatch :: MonadAWS m => D.BatchWriteItem -> m ()+retryWriteBatch cmd = do+ rs <- send cmd+ let unprocessed = rs ^. D.bwirsUnprocessedItems+ unless (null unprocessed) $ do+ liftIO $ threadDelay 1000000+ retryWriteBatch (cmd & D.bwiRequestItems .~ unprocessed)++-- | Retry batch operation, until unprocessedItems is empty.+--+-- TODO: we should use exponential backoff; currently we use a simple 1-sec threadDelay+retryReadBatch :: MonadAWS m => D.BatchGetItem -> m (HashMap T.Text [HashMap T.Text D.AttributeValue])+retryReadBatch = go mempty+ where+ go previous cmd = do+ rs <- send cmd+ let unprocessed = rs ^. D.bgirsUnprocessedKeys+ result = HMap.unionWith (++) previous (rs ^. D.bgirsResponses)+ if | null unprocessed -> return result+ | otherwise -> do+ liftIO $ threadDelay 1000000+ go result (cmd & D.bgiRequestItems .~ unprocessed)++-- | Chunk list according to batch operation limit+chunkBatch :: Int -> [a] -> [NonEmpty a]+chunkBatch limit (splitAt limit -> (x:xs, rest)) = (x :| xs) : chunkBatch limit rest+chunkBatch _ _ = []++-- | Batch write into the database.+--+-- The batch is divided to 25-item chunks, each is sent and retried separately.+-- If a batch fails on dynamodb exception, it is raised.+--+-- Note: On exception, the information about which items were saved is unavailable+putItemBatch :: forall m a r. (MonadAWS m, DynamoTable a r) => [a] -> m ()+putItemBatch lst = mapM_ go (chunkBatch 25 lst)+ where+ go items = do+ let tblname = tableName (Proxy :: Proxy a)+ wrequests = fmap mkrequest items+ mkrequest item = D.writeRequest & D.wrPutRequest .~ Just (D.putRequest & D.prItem .~ gsEncode item)+ cmd = D.batchWriteItem & D.bwiRequestItems . at tblname .~ Just wrequests+ retryWriteBatch cmd+++-- | Get batch of items.+getItemBatch :: forall m a r range hash rest.+ (MonadAWS m, DynamoTable a r, HasPrimaryKey a r 'IsTable, Code a ~ '[ hash ': range ': rest])+ => Consistency -> [PrimaryKey (Code a) r] -> m [a]+getItemBatch consistency lst = concat <$> mapM go (chunkBatch 100 lst)+ where+ go keys = do+ let tblname = tableName (Proxy :: Proxy a)+ wkaas = fmap (dKeyToAttr (Proxy :: Proxy a)) keys+ kaas = D.keysAndAttributes wkaas & D.kaaConsistentRead . consistencyL .~ consistency+ cmd = D.batchGetItem & D.bgiRequestItems . at tblname .~ Just kaas++ tbls <- retryReadBatch cmd+ mapM decoder (tbls ^.. ix tblname . traverse)+ decoder item =+ case gsDecode item of+ Just res -> return res+ Nothing -> throwM (DynamoException $ "Error decoding item: " <> T.pack (show item))++dDeleteRequest :: (HasPrimaryKey a r 'IsTable, Code a ~ '[ hash ': range ': xss ])+ => Proxy a -> PrimaryKey (Code a) r -> D.DeleteRequest+dDeleteRequest p pkey = D.deleteRequest & D.drKey .~ dKeyToAttr p pkey++-- | Batch version of 'deleteItemByKey'.+--+-- Note: Because the requests are chunked, the information about which items+-- were deleted in case of exception is unavailable.+deleteItemBatchByKey :: forall m a r range hash rest.+ (MonadAWS m, HasPrimaryKey a r 'IsTable, DynamoTable a r, Code a ~ '[ hash ': range ': rest])+ => Proxy a -> [PrimaryKey (Code a) r] -> m ()+deleteItemBatchByKey p lst = mapM_ go (chunkBatch 25 lst)+ where+ go keys = do+ let tblname = tableName p+ wrequests = fmap mkrequest keys+ mkrequest key = D.writeRequest & D.wrDeleteRequest .~ Just (dDeleteRequest p key)+ cmd = D.batchWriteItem & D.bwiRequestItems . at tblname .~ Just wrequests+ retryWriteBatch cmd
+ src/Database/DynamoDB/Class.hs view
@@ -0,0 +1,339 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+-- We have lots of pattern matching for allFieldNames, that is correct because of TH+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE UndecidableSuperClasses #-}+#endif++module Database.DynamoDB.Class (+ DynamoCollection(..)+ , DynamoTable(..)+ , DynamoIndex(..)+ , dQueryKey+ , dScan+ , RangeType(..)+ , TableType(..)+ , gsDecode+ , gsDecodeG+ , gsEncode+ , gsEncodeG+ , PrimaryKey+ , TableQuery+ , TableScan+ , TableCreate(..)+ , IndexCreate(..)+ , HasPrimaryKey(..)+ , createLocalIndex+) where++import Control.Lens ((.~), sequenceOf, _2)+import Data.Function ((&))+import qualified Data.HashMap.Strict as HMap+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Generics.SOP+import qualified Network.AWS.DynamoDB.CreateTable as D+import qualified Network.AWS.DynamoDB.PutItem as D+import qualified Network.AWS.DynamoDB.Query as D+import qualified Network.AWS.DynamoDB.Scan as D+import Network.AWS.DynamoDB.Types (ProvisionedThroughput,+ globalSecondaryIndex,+ keySchemaElement, AttributeValue)+import qualified Network.AWS.DynamoDB.Types as D+import Data.HashMap.Strict (HashMap)+import Data.Maybe (mapMaybe)+++import Database.DynamoDB.Internal (rangeOper, rangeData)+import Database.DynamoDB.Types+++-- | Data collection type - with hash key or with hash+sort key+data RangeType = NoRange | WithRange++-- | Helper type to distinguish index and table collections+data TableType = IsTable | IsIndex++-- | Basic instance for dynamo collection (table or index)+-- This instances fixes the tableName and the sort key+class (Generic a, All2 DynamoEncodable (Code a))+ => DynamoCollection a (r :: RangeType) (t :: TableType) | a -> r t where+ allFieldNames :: Proxy a -> [T.Text]+ primaryFields :: Proxy a -> [T.Text]++class DynamoCollection a r t => HasPrimaryKey a (r :: RangeType) (t :: TableType) where+ dItemToKey :: (Code a ~ '[ hash ': range ': xss ]) => a -> PrimaryKey (Code a) r+ dKeyToAttr :: (Code a ~ '[ hash ': range ': xss ])+ => Proxy a -> PrimaryKey (Code a) r -> HMap.HashMap T.Text D.AttributeValue+ dAttrToKey :: Proxy a -> HMap.HashMap T.Text D.AttributeValue -> Maybe (PrimaryKey (Code a) r)++instance (DynamoCollection a 'NoRange t, Code a ~ '[ hash ': xss ],+ DynamoScalar v hash) => HasPrimaryKey a 'NoRange t where+ dItemToKey = gdFirstField+ dKeyToAttr p key = HMap.singleton (head $ allFieldNames p) (dScalarEncode key)+ dAttrToKey p attrs = HMap.lookup (head $ allFieldNames p) attrs >>= dDecode . Just++instance (DynamoCollection a 'WithRange t, Code a ~ '[ hash ': range ': xss ],+ DynamoScalar v1 hash, DynamoScalar v2 range) => HasPrimaryKey a 'WithRange t where+ dItemToKey = gdTwoFields+ dKeyToAttr p (key, range) = HMap.fromList plist+ where+ (hashname:rangename:_) = allFieldNames p+ plist = [(hashname, dScalarEncode key), (rangename, dScalarEncode range)]+ dAttrToKey p attrs = do+ let (hashname:rangename:_) = allFieldNames p+ pkey <- HMap.lookup hashname attrs+ pval <- dDecode (Just pkey)+ rngkey <- HMap.lookup rangename attrs+ rngval <- dDecode (Just rngkey)+ return (pval, rngval)++-- | Descritpion of dynamo table+class DynamoCollection a r 'IsTable => DynamoTable a (r :: RangeType) | a -> r where+ -- | Dynamo table/index name; default is the constructor name+ tableName :: Proxy a -> T.Text+ -- | Serialize data, put it into the database+ dPutItem :: a -> D.PutItem+ dPutItem = defaultPutItem++-- | Dispatch class for NoRange/WithRange createTable+class DynamoTable a r => TableCreate a (r :: RangeType) where+ createTable :: (Code a ~ '[ hash ': range ': xss ]) => Proxy a -> ProvisionedThroughput -> D.CreateTable+instance (DynamoTable a 'NoRange, Code a ~ '[ hash ': rest ], DynamoScalar v hash) => TableCreate a 'NoRange where+ createTable = defaultCreateTable+instance (DynamoTable a 'WithRange, Code a ~ '[ hash ': range ': xss ], DynamoScalar v1 hash, DynamoScalar v2 range)+ => TableCreate a 'WithRange where+ createTable = defaultCreateTableRange++-- | Instance for tables that can be queried+class DynamoCollection a 'WithRange t => TableQuery a (t :: TableType) where+ -- | Return table name and index name+ qTableName :: Proxy a -> T.Text+ qIndexName :: Proxy a -> Maybe T.Text+ -- | Create a query using both hash key and operation on range key+ -- On tables without range key, this degrades to queryKey+ dQueryKey :: (Code a ~ '[ hash ': range ': rest ])+ => Proxy a -> hash -> Maybe (RangeOper range) -> D.Query+instance (DynamoCollection a 'WithRange 'IsTable, DynamoTable a 'WithRange,+ Code a ~ '[ hash ': range ': rest ], DynamoScalar v1 hash, DynamoScalar v2 range)+ => TableQuery a 'IsTable where+ dQueryKey = defaultQueryKey+ qTableName = tableName+ qIndexName _ = Nothing+instance (DynamoCollection a 'WithRange 'IsIndex, DynamoIndex a parent 'WithRange, DynamoTable parent r1,+ Code a ~ '[ hash ': range ': rest ], DynamoScalar v1 hash, DynamoScalar v2 range)+ => TableQuery a 'IsIndex where+ dQueryKey = defaultQueryKey+ qTableName _ = tableName (Proxy :: Proxy parent)+ qIndexName = Just . indexName++class DynamoCollection a r t => TableScan a (r :: RangeType) (t :: TableType) where+ -- | Return table name and index name+ qsTableName :: Proxy a -> T.Text+ qsIndexName :: Proxy a -> Maybe T.Text+ dScan :: Proxy a -> D.Scan+instance DynamoTable a r => TableScan a r 'IsTable where+ qsTableName = tableName+ qsIndexName _ = Nothing+ dScan = defaultScan+instance (DynamoCollection a r 'IsIndex,+ DynamoIndex a parent r, DynamoTable parent r1) => TableScan a r 'IsIndex where+ qsTableName _ = tableName (Proxy :: Proxy parent)+ qsIndexName = Just . indexName+ dScan = defaultScan++-- | Parameter type for queryKeyRange+type family PrimaryKey (a :: [[*]]) (r :: RangeType) :: * where+ PrimaryKey ('[ key ': range ': rest ] ) 'WithRange = (key, range)+ PrimaryKey ('[ key ': rest ]) 'NoRange = key++-- | Class representing a Global Secondary Index+class DynamoCollection a r 'IsIndex => DynamoIndex a parent (r :: RangeType) | a -> parent r where+ indexName :: Proxy a -> T.Text++class DynamoIndex a parent r => IndexCreate a parent (r :: RangeType) where+ createGlobalIndex ::+ (DynamoTable parent r2, Code parent ~ '[ xs ': rest2 ], Code a ~ '[hash ': range ': rest ])+ => Proxy a -> ProvisionedThroughput -> (D.GlobalSecondaryIndex, [D.AttributeDefinition])++instance (DynamoIndex a p 'NoRange, Code a ~ '[ hash ': rest ], DynamoScalar v hash) => IndexCreate a p 'NoRange where+ createGlobalIndex = defaultCreateGlobalIndex+instance (DynamoIndex a p 'WithRange, Code a ~ '[ hash ': range ': rest ], DynamoScalar v1 hash, DynamoScalar v2 range)+ => IndexCreate a p 'WithRange where+ createGlobalIndex = defaultCreateGlobalIndexRange++-- | Return first field of a datatype+gdFirstField :: forall a hash rest. (Generic a, Code a ~ '[ hash ': rest ]) => a -> hash+gdFirstField item = firstField (from item)+ where+ firstField :: (xs ~ '[ hash ': rest ]) => SOP I xs -> hash+ firstField (SOP (Z (start :* _))) = unI start+ firstField (SOP (S _)) = error "This cannot happen." -- or the signature is not enough?++-- | Return first 2 fields of a datatype+gdTwoFields :: forall a hash range rest. (Generic a, Code a ~ '[ hash ': range ': rest ])+ => a -> (hash, range)+gdTwoFields item = twoFields (from item)+ where+ twoFields :: (xs ~ '[ hash ': range ': rest ]) => SOP I xs -> (hash, range)+ twoFields (SOP (Z (start :* range :* _))) = (unI start, unI range)+ twoFields (SOP (S _)) = error "This cannot happen." -- or the signature is not good enough?++gsEncode :: forall a r t. DynamoCollection a r t => a -> HashMap T.Text AttributeValue+gsEncode = gsEncodeG (allFieldNames (Proxy :: Proxy a))++gsEncodeG :: forall a. (Generic a, All2 DynamoEncodable (Code a))+ => [T.Text] -> a -> HashMap T.Text AttributeValue+gsEncodeG names a = HMap.fromList $ mapMaybe (sequenceOf _2) $ zip names (gsEncode' (from a))+ where+ gsEncode' :: All2 DynamoEncodable xs => SOP I xs -> [Maybe AttributeValue]+ gsEncode' (SOP sop) = hcollapse $ hcliftA palldynamo gsEncodeRec sop++ gsEncodeRec :: All DynamoEncodable xss => NP I xss -> K [Maybe AttributeValue] xss+ gsEncodeRec = K . hcollapse . hcliftA pdynamo (K . dEncode . unI)++ palldynamo :: Proxy (All DynamoEncodable)+ palldynamo = Proxy++ pdynamo :: Proxy DynamoEncodable+ pdynamo = Proxy+++gsDecode :: forall a r t xs. (DynamoCollection a r t, Code a ~ '[ xs ])+ => HashMap T.Text AttributeValue -> Maybe a+gsDecode = gsDecodeG (allFieldNames (Proxy :: Proxy a))++-- | Decode hashmap to a record using generic-sop.+gsDecodeG ::+ forall a xs. (Generic a, All2 DynamoEncodable (Code a), Code a ~ '[ xs ])+ => [T.Text] -> HMap.HashMap T.Text AttributeValue -> Maybe a+gsDecodeG names attrs =+ let Just vals = fromList $ map (`HMap.lookup` attrs) names+ in to . SOP . Z <$> hsequence (hcliftA dproxy (dDecode . unK) vals)+ where+ dproxy = Proxy :: Proxy DynamoEncodable+++defaultPutItem :: forall a r. DynamoTable a r => a -> D.PutItem+defaultPutItem item = D.putItem tblname & D.piItem .~ gsEncode item+ where+ tblname = tableName (Proxy :: Proxy a)++defaultCreateTable :: forall a v hash rest. (DynamoTable a 'NoRange, Code a ~ '[ hash ': rest ], DynamoScalar v hash)+ => Proxy a -> ProvisionedThroughput -> D.CreateTable+defaultCreateTable p thr =+ D.createTable (tableName p) (hashKey :| []) thr+ & D.ctAttributeDefinitions .~ keyDefs+ where+ hashname = head (allFieldNames p)+ hashKey = keySchemaElement hashname D.Hash+ keyDefs = [D.attributeDefinition hashname (dType (Proxy :: Proxy hash))]++defaultCreateTableRange :: forall a hash range rest v1 v2.+ (DynamoTable a 'WithRange, Code a ~ '[ hash ': range ': rest ], DynamoScalar v1 hash, DynamoScalar v2 range)+ => Proxy a -> ProvisionedThroughput -> D.CreateTable+defaultCreateTableRange p thr =+ D.createTable (tableName p) (hashKey :| [rangeKey]) thr+ & D.ctAttributeDefinitions .~ keyDefs+ where+ (hashname:rangename:_) = allFieldNames p+ hashKey = keySchemaElement hashname D.Hash+ rangeKey = keySchemaElement rangename D.Range+ keyDefs = [D.attributeDefinition hashname (dType (Proxy :: Proxy hash)),+ D.attributeDefinition rangename (dType (Proxy :: Proxy range))]++defaultQueryKey :: (TableQuery a t, Code a ~ '[ hash ': range ': rest ], DynamoScalar v1 hash, DynamoScalar v2 range)+ => Proxy a -> hash -> Maybe (RangeOper range) -> D.Query+defaultQueryKey p key Nothing =+ D.query (qTableName p) & D.qKeyConditionExpression .~ Just "#K = :key"+ & D.qExpressionAttributeNames .~ HMap.singleton "#K" hashname+ & D.qExpressionAttributeValues .~ HMap.singleton ":key" (dScalarEncode key)+ & D.qIndexName .~ qIndexName p+ where+ (hashname:_) = allFieldNames p+defaultQueryKey p key (Just range) =+ D.query (qTableName p) & D.qKeyConditionExpression .~ Just condExpression+ & D.qExpressionAttributeNames .~ attrnames+ & D.qExpressionAttributeValues .~ attrvals+ & D.qIndexName .~ qIndexName p+ where+ rangeSubst = "#R"+ condExpression = "#K = :key AND " <> rangeOper range rangeSubst+ attrnames = HMap.fromList [("#K", hashname), (rangeSubst, rangename)]+ attrvals = HMap.fromList $ rangeData range ++ [(":key", dScalarEncode key)]+ (hashname:rangename:_) = allFieldNames p++defaultCreateGlobalIndex :: forall a r parent r2 hash rest v.+ (DynamoIndex a parent r, DynamoTable parent r2, Code a ~ '[hash ': rest ], DynamoScalar v hash)+ => Proxy a -> ProvisionedThroughput -> (D.GlobalSecondaryIndex, [D.AttributeDefinition])+defaultCreateGlobalIndex p thr =+ (globalSecondaryIndex (indexName p) keyschema proj thr, attrdefs)+ where+ (hashname:_) = allFieldNames p+ attrdefs = [D.attributeDefinition hashname (dType (Proxy :: Proxy hash))]+ keyschema = keySchemaElement hashname D.Hash :| []+ proj | Just lst <- nonEmpty attrlist =+ D.projection & D.pProjectionType .~ Just D.Include+ & D.pNonKeyAttributes .~ Just lst+ | otherwise = D.projection & D.pProjectionType .~ Just D.KeysOnly+ parentKey = primaryFields (Proxy :: Proxy parent)+ attrlist = filter (`notElem` (parentKey ++ [hashname])) $ allFieldNames (Proxy :: Proxy a)++mkIndexHelper :: forall a parent r2 hash rest range v1 v2.+ (DynamoIndex a parent 'WithRange, DynamoTable parent r2, Code a ~ '[hash ': range ': rest ],+ DynamoScalar v1 hash, DynamoScalar v2 range) =>+ Proxy a -> (NonEmpty D.KeySchemaElement, D.Projection, [D.AttributeDefinition])+mkIndexHelper p = (keyschema, proj, attrdefs)+ where+ (hashname:rangename:_) = allFieldNames p+ (hashproxy, rangeproxy) = (Proxy :: Proxy hash, Proxy :: Proxy range)+ attrdefs = [D.attributeDefinition hashname (dType hashproxy), D.attributeDefinition rangename (dType rangeproxy)]+ --+ keyschema = keySchemaElement hashname D.Hash :| [keySchemaElement rangename D.Range]+ --+ proj | Just lst <- nonEmpty attrlist =+ D.projection & D.pProjectionType .~ Just D.Include+ & D.pNonKeyAttributes .~ Just lst+ | otherwise = D.projection & D.pProjectionType .~ Just D.KeysOnly+ parentKey = primaryFields (Proxy :: Proxy parent)+ attrlist = filter (`notElem` (parentKey ++ [hashname, rangename])) $ allFieldNames (Proxy :: Proxy a)++defaultCreateGlobalIndexRange :: forall a parent r2 hash rest xs rest2 range v1 v2.+ (DynamoIndex a parent 'WithRange, DynamoTable parent r2, Code parent ~ '[ xs ': rest2 ],+ Code a ~ '[hash ': range ': rest ],+ DynamoScalar v1 hash, DynamoScalar v2 range) =>+ Proxy a -> ProvisionedThroughput -> (D.GlobalSecondaryIndex, [D.AttributeDefinition])+defaultCreateGlobalIndexRange p thr =+ (globalSecondaryIndex (indexName p) keyschema proj thr, attrdefs)+ where+ (keyschema, proj, attrdefs) = mkIndexHelper p++createLocalIndex :: forall a parent r2 hash rest xs rest2 range v1 v2.+ (DynamoIndex a parent 'WithRange, DynamoTable parent r2, Code parent ~ '[ xs ': rest2 ],+ Code a ~ '[hash ': range ': rest ],+ DynamoScalar v1 hash, DynamoScalar v2 range) =>+ Proxy a -> (D.LocalSecondaryIndex, [D.AttributeDefinition])+createLocalIndex p =+ (D.localSecondaryIndex (indexName p) keyschema proj, attrdefs)+ where+ (keyschema, proj, attrdefs) = mkIndexHelper p+++defaultScan :: (TableScan a r t) => Proxy a -> D.Scan+defaultScan p = D.scan (qsTableName p) & D.sIndexName .~ qsIndexName p
+ src/Database/DynamoDB/Filter.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module for creating filter conditions+--+-- Example as used in nested structure for scan:+--+-- > scanCond (colCtvrty <!:> "a" <.> colInTreti <.> colInnPrvni ==. "x") 20+module Database.DynamoDB.Filter (+ -- * Condition datatype+ FilterCondition(Not)+ -- * Logical operators+ , (&&.), (||.)+ -- * Equality comparisons+ , (==.), (/=.), (>=.), (>.), (<=.), (<.)+ -- * Extended functions+ , attrExists, attrMissing, beginsWith, contains, setContains, valIn, between+ , size+) where++import Control.Lens ((.~))+import Data.Function ((&))+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Network.AWS.DynamoDB.Types as D++import Database.DynamoDB.Internal+import Database.DynamoDB.Types++-- | Numeric/string range comparison.+between :: (Ord typ, InCollection col tbl 'FullPath, DynamoScalar v typ)+ => Column typ ctyp col -> (typ, typ) -> FilterCondition tbl+between col (a, b) = Between (nameGen col) (dScalarEncode a) (dScalarEncode b)++-- | a IN (b, c, d); the list may contain up to 100 values.+valIn :: (InCollection col tbl 'FullPath, DynamoScalar v typ)+ => Column typ ctyp col -> [typ] -> FilterCondition tbl+valIn col lst = In (nameGen col) (map dScalarEncode lst)++-- | Check existence of attribute.+attrExists :: (InCollection col tbl 'FullPath) => Column typ 'TypColumn col -> FilterCondition tbl+attrExists col = AttrExists (nameGen col)++-- | Checks non-existence of an attribute+attrMissing :: (InCollection col tbl 'FullPath) => Column typ 'TypColumn col -> FilterCondition tbl+attrMissing col = AttrMissing (nameGen col)++-- | Comparison for text columns.+beginsWith :: (InCollection col tbl 'FullPath, IsText typ)+ => Column typ 'TypColumn col -> T.Text -> FilterCondition tbl+beginsWith col txt = BeginsWith (nameGen col) (dScalarEncode txt)++-- | CONTAINS condition for text-like attributes.+contains :: (InCollection col tbl 'FullPath, IsText typ)+ => Column typ 'TypColumn col -> T.Text -> FilterCondition tbl+contains col txt = Contains (nameGen col) (dScalarEncode txt)++-- | CONTAINS condition for sets.+setContains :: (InCollection col tbl 'FullPath, DynamoScalar v a)+ => Column (Set.Set a) 'TypColumn col -> a -> FilterCondition tbl+setContains col txt = Contains (nameGen col) (dScalarEncode txt)++-- | Size (i.e. number of bytes) of saved attribute.+size :: Column typ 'TypColumn col -> Column Int 'TypSize col+size (Column lst) = Size lst++dcomp :: (InCollection col tbl 'FullPath, DynamoEncodable typ)+ => T.Text -> Column typ ctyp col -> typ -> FilterCondition tbl+dcomp op col val = Comparison (nameGen col) op encval+ where+ -- Ord comparing against nothing doesn't make much sense - failback to NULL+ encval = fromMaybe (D.attributeValue & D.avNULL .~ Just True) (dEncode val)++-- | AND for combining conditions.+(&&.) :: FilterCondition t -> FilterCondition t -> FilterCondition t+(&&.) = And+infixr 3 &&.++-- | OR for combining conditions+(||.) :: FilterCondition t -> FilterCondition t -> FilterCondition t+(||.) = Or+infixr 3 ||.++-- | Tests for equality. Automatically adjusts query to account for missing attributes.+--+-- Note: checks against empty values esentially translate to 'attrMissing'.+(==.) :: (InCollection col tbl 'FullPath, DynamoEncodable typ)+ => Column typ ctyp col -> typ -> FilterCondition tbl+(==.) col val =+ case dEncode val of+ -- Hack to have '==. Nothing' correctly working+ Nothing -> AttrMissing (nameGen col)+ -- Hack for '==. ""' or empty set, list, hashmap to work correctly on non-initialized values+ Just encval | dIsMissing val -> AttrMissing (nameGen col) ||. Comparison (nameGen col) "=" encval+ | otherwise -> Comparison (nameGen col) "=" encval+infix 4 ==.++-- | > a /= b === Not (a == b)+(/=.) :: (InCollection col tbl 'FullPath, DynamoEncodable typ)+ => Column typ ctyp col -> typ -> FilterCondition tbl+(/=.) col val = Not (dcomp "=" col val)+infix 4 /=.+++(<=.) :: (InCollection col tbl 'FullPath, DynamoEncodable typ, Ord typ)+ => Column typ ctyp col -> typ -> FilterCondition tbl+(<=.) = dcomp "<="+infix 4 <=.++(<.) :: (InCollection col tbl 'FullPath, DynamoEncodable typ, Ord typ)+ => Column typ ctyp col -> typ -> FilterCondition tbl+(<.) = dcomp "<"+infix 4 <.++(>.) :: (InCollection col tbl 'FullPath, DynamoEncodable typ, Ord typ)+ => Column typ ctyp col -> typ -> FilterCondition tbl+(>.) = dcomp ">"+infix 4 >.++(>=.) :: (InCollection col tbl 'FullPath, DynamoEncodable typ, Ord typ)+ => Column typ ctyp col -> typ -> FilterCondition tbl+(>=.) = dcomp ">="+infix 4 >=.
+ src/Database/DynamoDB/Internal.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module Database.DynamoDB.Internal where++import Control.Lens (Iso', iso)+import Control.Monad.Supply (Supply, evalSupply, supply)+import Data.Foldable (foldlM)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup ((<>))+import Data.Proxy+import qualified Data.Text as T+import Network.AWS.DynamoDB.Types (AttributeValue)+import qualified Network.AWS.DynamoDB.Types as D+import qualified Data.Semigroup as SEMI++import Database.DynamoDB.Types++data ColumnType = TypColumn | TypSize+-- | Representation of a column for filter queries+-- typ - datatype of column (Int, Text..)+-- coltype - TypColumn or TypSize (result of size(column))+-- col - instance of ColumnInfo, uniquely identify a column+data Column typ (coltype :: ColumnType) col where+ Column :: NonEmpty IntraColName -> Column typ 'TypColumn col+ Size :: NonEmpty IntraColName -> Column Int 'TypSize col++-- | Smart constructor for Column datatype+mkColumn :: forall typ col. ColumnInfo col => Column typ 'TypColumn col+mkColumn = Column (IntraName (columnName (Proxy :: Proxy col)) :| [])++-- | Internal representation of a part of path in a nested structure+data IntraColName = IntraName T.Text | IntraIndex Int++-- Type of query for InCollection (we cannot query on primary key)+data PathType = NestedPath | FullPath++-- | Signifies that the column is present in the table/index+class ColumnInfo col => InCollection col tbl (query :: PathType)++-- | Class to get a column name from a Type specifying a column+class ColumnInfo a where+ columnName :: Proxy a -> T.Text++type NameGen = Supply T.Text T.Text -> Supply T.Text (T.Text, HashMap T.Text T.Text)+nameGen :: Column typ ctyp col -> NameGen+nameGen (Column lst) mkident = nameGenPath lst mkident+nameGen (Size lst) mkident = do+ (path, attrs) <- nameGenPath lst mkident+ return ("size(" <> path <> ")", attrs)++nameGenPath :: NonEmpty IntraColName -> Supply T.Text T.Text -> Supply T.Text (T.Text, HashMap T.Text T.Text)+nameGenPath lst mkident = foldlM joinParts ("", HMap.empty) lst+ where+ joinParts ("", attrs) (IntraName nm) = do+ ident <- mkident+ return (ident, attrs <> HMap.singleton ident nm)+ joinParts (expr, attrs) (IntraName nm) = do+ ident <- mkident+ return (expr <> "." <> ident, attrs <> HMap.singleton ident nm)+ joinParts (expr, attrs) (IntraIndex idx) = return (expr <> "[" <> T.pack (show idx) <> "]", attrs)++-- | Filter condition. Use with scan, query, update and delete methods.+--+-- Filtering on primary key is not allowed.+data FilterCondition t =+ And (FilterCondition t) (FilterCondition t)+ | Or (FilterCondition t) (FilterCondition t)+ | Not (FilterCondition t) -- ^ Negate condition+ | Comparison NameGen T.Text D.AttributeValue+ | AttrExists NameGen+ | AttrMissing NameGen+ | BeginsWith NameGen D.AttributeValue+ | Contains NameGen D.AttributeValue+ | Between NameGen D.AttributeValue D.AttributeValue+ | In NameGen [D.AttributeValue]++instance SEMI.Semigroup (FilterCondition t) where+ (<>) = And++-- | Return filter expression, attribute name map and attribute value map+dumpCondition :: FilterCondition t -> (T.Text, HashMap T.Text T.Text, HashMap T.Text D.AttributeValue)+dumpCondition fcondition = evalSupply (go fcondition) names+ where+ names = map (\i -> T.pack ("G" <> show i)) ([1..] :: [Int])+ supplyName = ("#" <>) <$> supply+ supplyValue = (":" <> ) <$> supply+ go (And cond1 cond2) = do+ (t1, a1, v1) <- go cond1+ (t2, a2, v2) <- go cond2+ return ("(" <> t1 <> ") AND (" <> t2 <> ")", a1 <> a2, v1 <> v2)+ go (Or cond1 cond2) = do+ (t1, a1, v1) <- go cond1+ (t2, a2, v2) <- go cond2+ return ("(" <> t1 <> ") OR (" <> t2 <> ")", a1 <> a2, v1 <> v2)+ go (Not cond) = do+ (t, a, v) <- go cond+ return ("NOT (" <> t <> ")", a, v)+ go (Comparison name oper val) = do+ idval <- supplyValue+ (subst, attrnames) <- name supplyName+ let expr = subst <> " " <> oper <> " " <> idval+ return (expr, attrnames, HMap.singleton idval val)+ go (Between name v1 v2) = do+ idstart <- supplyValue+ idstop <- supplyValue+ (subst, attrnames) <- name supplyName+ let expr = subst <> " BETWEEN " <> idstart <> " AND " <> idstop+ vals = HMap.fromList [(idstart, v1), (idstop, v2)]+ return (expr, attrnames, vals)++ go (In name lst) = do+ (subst, attrnames) <- name supplyName+ vlist <- mapM (\val -> (,val) <$> supplyValue) lst+ let expr = T.intercalate "," $ map fst vlist+ return (subst <> " IN (" <> expr <> ")", attrnames, HMap.fromList vlist)++ go (AttrExists name) = do+ (subst, attrnames) <- name supplyName+ let expr = "attribute_exists(" <> subst <> ")"+ return (expr, attrnames, HMap.empty)+ go (AttrMissing name) = do+ (subst, attrnames) <- name supplyName+ let expr = "attribute_not_exists(" <> subst <> ")"+ return (expr, attrnames, HMap.empty)+ go (BeginsWith name val) = do+ idval <- supplyValue+ (subst, attrnames) <- name supplyName+ let expr = "begins_with(" <> subst <> ", " <> idval <> ")"+ return (expr, attrnames, HMap.singleton idval val)+ go (Contains name val) = do+ idval <- supplyValue+ (subst, attrnames) <- name supplyName+ let expr = "contains(" <> subst <> ", " <> idval <> ")"+ return (expr, attrnames, HMap.singleton idval val)++rangeKey :: T.Text+rangeKey = ":rangekey"++rangeStart :: T.Text+rangeStart = ":rangeStart"++rangeEnd :: T.Text+rangeEnd = ":rangeEnd"++rangeOper :: RangeOper a -> T.Text -> T.Text+rangeOper (RangeEquals _) n = n <> " = " <> rangeKey+rangeOper (RangeLessThan _) n = n <> " < " <> rangeKey+rangeOper (RangeLessThanE _) n = n <> " <= " <> rangeKey+rangeOper (RangeGreaterThan _) n = n <> " > " <> rangeKey+rangeOper (RangeGreaterThanE _) n = n <> " >= " <> rangeKey+rangeOper (RangeBetween _ _) n = n <> " BETWEEN " <> rangeStart <> " AND " <> rangeEnd+rangeOper (RangeBeginsWith _) n = "begins_with(" <> n <> ", " <> rangeKey <> ")"++rangeData :: DynamoScalar v a => RangeOper a -> [(T.Text, AttributeValue)]+rangeData (RangeEquals a) = [(rangeKey, dScalarEncode a)]+rangeData (RangeLessThan a) = [(rangeKey, dScalarEncode a)]+rangeData (RangeLessThanE a) = [(rangeKey, dScalarEncode a)]+rangeData (RangeGreaterThan a) = [(rangeKey, dScalarEncode a)]+rangeData (RangeGreaterThanE a) = [(rangeKey, dScalarEncode a)]+rangeData (RangeBetween s e) = [(rangeStart, dScalarEncode s), (rangeEnd, dScalarEncode e)]+rangeData (RangeBeginsWith a) = [(rangeKey, dScalarEncode a)]++-- | Parameter for queries involving read consistency settings.+data Consistency = Eventually | Strongly+ deriving (Show)++-- | Lens to help set consistency.+consistencyL :: Iso' (Maybe Bool) Consistency+consistencyL = iso tocons fromcons+ where+ tocons (Just True) = Strongly+ tocons _ = Eventually+ fromcons Strongly = Just True+ fromcons Eventually = Just False++-- | Query direction+data Direction = Forward | Backward+ deriving (Show, Eq)+++-- | Allow skipping over maybe types when using <.>+type family UnMaybe a :: * where+ UnMaybe (Maybe a) = a+ UnMaybe a = a++-- | Combine attributes from nested structures.+--+-- > colAddress <.> colStreet+(<.>) :: (InCollection col2 (UnMaybe typ) 'NestedPath)+ => Column typ 'TypColumn col1 -> Column typ2 'TypColumn col2 -> Column typ2 'TypColumn col1+(<.>) (Column a1) (Column a2) = Column (a1 <> a2)+-- It doesn't matter if it is inifxl or infixr; obviously this can be Semigroup instance,+-- but currently as semigroup is not a superclass of monoid, it is probably better to have+-- our own operator.+infixl 7 <.>++-- | Access an index in a nested list.+--+-- > colUsers <!> 0 <.> colName+(<!>) :: Column [typ] 'TypColumn col -> Int -> Column typ 'TypColumn col+(<!>) (Column a1) num = Column (a1 <> pure (IntraIndex num))+infixl 8 <!>++-- | Access a key in a nested hashmap.+--+-- > colPhones <!:> "mobile" <.> colNumber+(<!:>) :: IsText key => Column (HashMap key typ) 'TypColumn col -> key -> Column typ 'TypColumn col+(<!:>) (Column a1) key = Column (a1 <> pure (IntraName (toText key)))+infixl 8 <!:>
+ src/Database/DynamoDB/Migration.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++module Database.DynamoDB.Migration (+ runMigration+) where++import Control.Arrow (first)+import Control.Concurrent (threadDelay)+import Control.Lens (_1, set, view, (%~), (.~),+ (^.), (^..), (^?), _Just)+import Control.Monad (unless, void, when)+import Control.Monad.Catch (throwM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Loops (whileM_)+import Control.Monad.Trans.AWS (AWSConstraint)+import Data.Bool (bool)+import Data.Foldable (toList)+import Data.Function ((&))+import qualified Data.HashMap.Strict as HMap+import Data.List (nub, (\\))+import Data.Maybe (mapMaybe, fromMaybe)+import Data.Monoid ((<>))+import Data.Proxy+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8Builder)+import Generics.SOP+import Network.AWS+import qualified Network.AWS.DynamoDB.CreateTable as D+import qualified Network.AWS.DynamoDB.DescribeTable as D+import qualified Network.AWS.DynamoDB.Types as D+import qualified Network.AWS.DynamoDB.UpdateTable as D++import Database.DynamoDB.Class+import Database.DynamoDB.Types++getTableDescription :: MonadAWS m => T.Text -> m D.TableDescription+getTableDescription tblname = do+ rs <- send (D.describeTable tblname)+ case rs ^? D.drsTable . _Just of+ Just descr -> return descr+ Nothing -> throwM (DynamoException "getTableStatus - did not get correct data")++-- | Periodically check state of table, until it is ACTIVE+waitUntilTableActive :: forall r m. (AWSConstraint r m, MonadAWS m) => T.Text -> Bool -> m ()+waitUntilTableActive name checkindex =+ whileM_ tableIsNotActive $ do+ logmsg Info $ "Waiting for table " <> name <> " and its indices to become active"+ liftIO $ threadDelay 5000000+ where+ tableIsNotActive :: m Bool+ tableIsNotActive = do+ descr <- getTableDescription name+ status <- maybe (throwM (DynamoException "Missing table status")) return (descr ^. D.tdTableStatus)+ let idxstatus = descr ^.. D.tdGlobalSecondaryIndexes . traverse . D.gsidIndexStatus . _Just+ if | checkindex -> return (status /= D.Active || any (/= D.ISActive) idxstatus)+ | otherwise -> return (status /= D.Active)++-- | Delete specified indices from the database+deleteIndices :: forall m. MonadAWS m => T.Text -> [T.Text] -> m ()+deleteIndices tblname indices = do+ let idxupdates = map (\name -> set D.gsiuDelete (Just $ D.deleteGlobalSecondaryIndexAction name) D.globalSecondaryIndexUpdate) indices+ cmd = D.updateTable tblname & D.utGlobalSecondaryIndexUpdates .~ idxupdates+ void $ send cmd++-- | Update table with specified new indices+createIndices :: forall m. MonadAWS m => D.CreateTable -> [D.GlobalSecondaryIndex] -> m ()+createIndices table indices = do+ let tblname = table ^. D.ctTableName+ idxupdates = map (\idx -> set D.gsiuCreate (Just $ mkidx idx) D.globalSecondaryIndexUpdate) indices+ cmd = D.updateTable tblname & D.utGlobalSecondaryIndexUpdates .~ idxupdates+ & D.utAttributeDefinitions .~ (table ^. D.ctAttributeDefinitions)+ void $ send cmd+ where+ mkidx :: D.GlobalSecondaryIndex -> D.CreateGlobalSecondaryIndexAction+ mkidx idx = D.createGlobalSecondaryIndexAction (idx ^. D.gsiIndexName) (idx ^. D.gsiKeySchema)+ (idx ^. D.gsiProjection) (idx ^. D.gsiProvisionedThroughput)++-- | Compare intersection of new and old indexes and find inconsistent ones+findInconsistentIdxes :: [D.GlobalSecondaryIndex] -> [D.GlobalSecondaryIndexDescription] -> [D.GlobalSecondaryIndex]+findInconsistentIdxes newidxes oldidxes =+ map fst $ filter hasConflict $ toList $ HMap.intersectionWith (,) newmap oldmap+ where+ newmap = HMap.fromList $ map (\idx -> (idx ^. D.gsiIndexName, idx)) newidxes+ oldmap = HMap.fromList $ mapMaybe (\idx -> (,idx) <$> idx ^. D.gsidIndexName) oldidxes+ --+ hasConflict (newidx, oldix) = not (projectionOk newidx oldix && keysOk newidx oldix)+ keysOk newidx oldidx = Just (newidx ^. D.gsiKeySchema) == oldidx ^. D.gsidKeySchema+ -- Assume the indices were created by this module and we want them exactly the same+ projectionOk newidx oldidx =+ -- Allow the index to have more fields than we know about+ newprojtype == Just D.KeysOnly || (newprojtype == oldprojtype && newkeys `Set.isSubsetOf` oldkeys)+ where+ newprojtype = newidx ^? D.gsiProjection . D.pProjectionType . _Just+ oldprojtype = oldidx ^? D.gsidProjection . _Just . D.pProjectionType . _Just+ newkeys = Set.fromList $ newidx ^.. D.gsiProjection . D.pNonKeyAttributes . _Just . traverse+ oldkeys = Set.fromList $ oldidx ^.. D.gsidProjection . _Just . D.pNonKeyAttributes . _Just . traverse++-- | Verbatim copy of findInconsistentIdxes, but changed to localSecondaryIndex structure+findInconsistentLocIdxes :: [D.LocalSecondaryIndex] -> [D.LocalSecondaryIndexDescription] -> [T.Text]+findInconsistentLocIdxes newidxes oldidxes =+ map (view (_1 . D.lsiIndexName)) $ filter hasConflict $ toList $ HMap.intersectionWith (,) newmap oldmap+ where+ newmap = HMap.fromList $ map (\idx -> (idx ^. D.lsiIndexName, idx)) newidxes+ oldmap = HMap.fromList $ mapMaybe (\idx -> (,idx) <$> idx ^. D.lsidIndexName) oldidxes+ --+ hasConflict (newidx, oldix) = not (projectionOk newidx oldix && keysOk newidx oldix)+ keysOk newidx oldidx = Just (newidx ^. D.lsiKeySchema) == oldidx ^. D.lsidKeySchema+ -- Assume the indices were created by this module and we want them exactly the same+ projectionOk newidx oldidx =+ newprojtype == Just D.KeysOnly || (newprojtype == oldprojtype && newkeys `Set.isSubsetOf` oldkeys)+ where+ newprojtype = newidx ^? D.lsiProjection . D.pProjectionType . _Just+ oldprojtype = oldidx ^? D.lsidProjection . _Just . D.pProjectionType . _Just+ newkeys = Set.fromList $ newidx ^.. D.lsiProjection . D.pNonKeyAttributes . _Just . traverse+ oldkeys = Set.fromList $ oldidx ^.. D.lsidProjection . _Just . D.pNonKeyAttributes . _Just . traverse+++-- | Compare indexes and return list of indices to delete and to create; indices to recreate are included+compareIndexes :: D.CreateTable -> D.TableDescription -> ([T.Text], [D.GlobalSecondaryIndex])+compareIndexes tabledef descr = (todelete, tocreate)+ where+ newidxlist = tabledef ^. D.ctGlobalSecondaryIndexes+ oldidxlist = descr ^. D.tdGlobalSecondaryIndexes+ newidxnames = newidxlist ^.. traverse . D.gsiIndexName+ oldidxnames = oldidxlist ^.. traverse . D.gsidIndexName . _Just+ --+ recreate = findInconsistentIdxes newidxlist oldidxlist+ todelete = map (view D.gsiIndexName) recreate ++ (oldidxnames \\ newidxnames)+ tocreate = recreate ++ filter (\idx -> idx ^. D.gsiIndexName `notElem` oldidxnames) newidxlist++compareLocalIndexes :: MonadAWS m => D.CreateTable -> D.TableDescription -> m ()+compareLocalIndexes tabledef descr = do+ let newidxlist = tabledef ^. D.ctLocalSecondaryIndexes+ oldidxlist = descr ^. D.tdLocalSecondaryIndexes+ newidxnames = newidxlist ^.. traverse . D.lsiIndexName+ oldidxnames = oldidxlist ^.. traverse . D.lsidIndexName . _Just+ missing = filter (`notElem` oldidxnames) newidxnames+ unless (null missing) $+ throwM (DynamoException ("Missing local secondary indexes: " <> T.intercalate "," missing))+ let inconsistent = findInconsistentLocIdxes newidxlist oldidxlist+ unless (null inconsistent) $+ throwM (DynamoException ("Inconsistent local index settings (projection/types): "+ <> T.intercalate "," inconsistent))++-- | Change streaming settings on a table+changeStream :: (AWSConstraint r m, MonadAWS m)+ => T.Text -> Maybe D.StreamSpecification -> Maybe D.StreamSpecification -> m ()+changeStream _ Nothing Nothing = return ()+changeStream tblname (Just _) Nothing = do+ logmsg Info "Disabling streaming."+ waitUntilTableActive tblname False+ let strspec = D.streamSpecification & D.ssStreamEnabled .~ Just False+ cmd = D.updateTable tblname & D.utStreamSpecification .~ Just strspec+ void (send cmd)+changeStream tblname Nothing (Just new) = do+ waitUntilTableActive tblname False+ logmsg Info "Enabling streaming."+ let cmd = D.updateTable tblname & D.utStreamSpecification .~ Just new+ void (send cmd)+changeStream tblname (Just old) (Just new) = do+ changeStream tblname (Just old) Nothing+ changeStream tblname Nothing (Just new)+++-- | Main table migration code+tryMigration :: (AWSConstraint r m, MonadAWS m) => D.CreateTable -> D.TableDescription -> m ()+tryMigration tabledef descr = do+ -- Check key schema on the main table, fail if it changed.+ let tblkeys = tabledef ^. D.ctKeySchema+ oldtblkeys = descr ^. D.tdKeySchema+ when (Just tblkeys /= oldtblkeys) $ do+ let msg = "Table " <> tblname <> " hash/range key mismatch; new table: "+ <> T.pack (show tblkeys) <> ", old table: " <> T.pack (show oldtblkeys)+ logmsg Error msg+ throwM (DynamoException msg)++ -- Check that types of key attributes are the same+ unless (null conflictTableAttrs) $ do+ let msg = "Table or index " <> tblname <> " has conflicting attribute key types: " <> T.pack (show conflictTableAttrs)+ logmsg Error msg+ throwM (DynamoException msg)++ -- Check that local indexes are in sync with the settings. Fails if inconsistent.+ compareLocalIndexes tabledef descr++ -- Adjust indexes+ let (todelete, tocreate) = compareIndexes tabledef descr+ unless (null todelete) $ do+ waitUntilTableActive tblname False+ logmsg Info $ "Deleting indices: " <> T.intercalate "," todelete+ deleteIndices tblname todelete+ unless (null tocreate) $ do+ waitUntilTableActive tblname True+ logmsg Info $ "Create new indices: " <> T.intercalate "," (tocreate ^.. traverse . D.gsiIndexName)+ createIndices tabledef tocreate+ -- Check streaming settings+ when (tabledef ^. D.ctStreamSpecification /= descr ^. D.tdStreamSpecification) $+ changeStream tblname (descr ^. D.tdStreamSpecification) (tabledef ^. D.ctStreamSpecification)+ -- Done+ logmsg Info $ "Table " <> tblname <> " schema check done."+ where+ tblname = tabledef ^. D.ctTableName+ -- Compare tableattribute types from old and new tables+ conflictTableAttrs =+ let attrToTup = (,) <$> view D.adAttributeName <*> view D.adAttributeType+ attrdefs = HMap.fromList $ map attrToTup (tabledef ^. D.ctAttributeDefinitions)+ olddefs = HMap.fromList $ map attrToTup (descr ^. D.tdAttributeDefinitions)+ commonkeys = HMap.intersectionWith (,) attrdefs olddefs+ in+ HMap.toList $ HMap.filter (uncurry (/=)) commonkeys+++logmsg :: AWSConstraint r m => LogLevel -> T.Text -> m ()+logmsg level text = do+ logger <- view envLogger+ liftIO $ logger level (encodeUtf8Builder text)++prettyTableInfo :: D.CreateTable -> T.Text+prettyTableInfo tblinfo =+ tblname <> "(" <> tkeys <> ")" <> indexinfo idxlist+ where+ tblname = tblinfo ^. D.ctTableName+ tkeys = T.intercalate "," $ tblinfo ^.. (D.ctKeySchema . traverse . D.kseAttributeName)+ idxlist = tblinfo ^. D.ctGlobalSecondaryIndexes+ indexinfo [] = ""+ indexinfo lst = " with indexes: " <> T.intercalate ", " (map printidx lst)+ printidx idx = idx ^. D.gsiIndexName <> "(" <> ikeys idx <> ")"+ ikeys idx = T.intercalate "," $ idx ^.. (D.gsiKeySchema . traverse . D.kseAttributeName)++createOrMigrate :: (AWSConstraint r m, MonadAWS m) => D.CreateTable -> m ()+createOrMigrate tabledef = do+ let tblname = tabledef ^. D.ctTableName+ ers <- trying _ServiceError $ send (D.describeTable tblname)+ case ers of+ Left _ -> do+ logmsg Info ("Creating table: " <> prettyTableInfo tabledef)+ void $ send tabledef -- table doesn't exist, create a new one+ Right rs+ | Just descr <- rs ^. D.drsTable -> do+ logmsg Info ("Table " <> tblname <> " alread exists, checking schema.")+ tryMigration tabledef descr+ | otherwise -> throwM (DynamoException "Didn't receive correct table description.")++runMigration :: (TableCreate table r, MonadAWS m, Code table ~ '[ hash ': range ': rest ])+ => Proxy table+ -> [D.ProvisionedThroughput -> (D.GlobalSecondaryIndex, [D.AttributeDefinition])]+ -> [(D.LocalSecondaryIndex, [D.AttributeDefinition])]+ -> HMap.HashMap T.Text D.ProvisionedThroughput+ -> Maybe D.StreamViewType+ -> m ()+runMigration ptbl globindices' locindices provisionMap stream =+ liftAWS $ do+ let tbl = createTable ptbl (getProv (tableName ptbl))+ globindices = map (first adjustProv . ($ defaultprov)) globindices'+ idxattrs = concatMap snd globindices ++ concatMap snd locindices+ -- Bug in amazonka, we must not set the attribute if it is empty+ -- see https://github.com/brendanhay/amazonka/issues/332+ let final = tbl & bool (D.ctGlobalSecondaryIndexes .~ map fst globindices) id (null globindices)+ & bool (D.ctLocalSecondaryIndexes .~ map fst locindices) id (null locindices)+ & D.ctAttributeDefinitions %~ (nub . (<> idxattrs))+ & addStream stream+ createOrMigrate final+ where+ getProv name = fromMaybe defaultprov (HMap.lookup name provisionMap)+ defaultprov = D.provisionedThroughput 5 5+ adjustProv idx = idx & (D.gsiProvisionedThroughput .~ getProv (idx ^. D.gsiIndexName))+ addStream Nothing = id+ addStream (Just stype) =+ let strspec = D.streamSpecification & D.ssStreamEnabled .~ Just True+ & D.ssStreamViewType .~ Just stype+ in D.ctStreamSpecification .~ Just strspec
+ src/Database/DynamoDB/QueryRequest.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Database.DynamoDB.QueryRequest (+ -- * Query+ query+ , querySimple+ , queryCond+ , querySource+ -- * Scan+ , scan+ , scanCond+ , scanSource+ -- * Query options+ , QueryOpts+ , queryOpts+ , qConsistentRead, qStartKey, qDirection, qFilterCondition, qHashKey, qRangeCondition, qLimit+ -- * Scan options+ , ScanOpts+ , scanOpts+ , sFilterCondition, sConsistentRead, sLimit, sParallel, sStartKey+) where+++import Control.Arrow (first)+import Control.Lens (view, (%~), (.~), (^.), Lens')+import Control.Lens.TH (makeLenses)+import Control.Monad.Catch (throwM)+import Data.Bool (bool)+import Data.Conduit (Conduit, Source, runConduit,+ (=$=))+import qualified Data.Conduit.List as CL+import Data.Function ((&))+import Data.HashMap.Strict (HashMap)+import Data.Monoid ((<>))+import Data.Proxy+import qualified Data.Text as T+import Generics.SOP+import Network.AWS+import qualified Network.AWS.DynamoDB.Query as D+import qualified Network.AWS.DynamoDB.Scan as D+import qualified Network.AWS.DynamoDB.Types as D+import Numeric.Natural (Natural)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Foldable (toList)++import Database.DynamoDB.Class+import Database.DynamoDB.Filter+import Database.DynamoDB.Internal+import Database.DynamoDB.Types+++-- | Helper function to decode data from the conduit.+rsDecode :: (MonadAWS m, Code a ~ '[ hash ': range ': rest], DynamoCollection a r t)+ => (i -> [HashMap T.Text D.AttributeValue]) -> Conduit i m a+rsDecode trans = CL.mapFoldable trans =$= CL.mapM rsDecoder++rsDecoder :: (MonadAWS m, Code a ~ '[ hash ': range ': rest], DynamoCollection a r t)+ => HashMap T.Text D.AttributeValue -> m a+rsDecoder item =+ case gsDecode item of+ Just res -> return res+ Nothing -> throwM (DynamoException $ "Error decoding item: " <> T.pack (show item))++-- | Options for a generic query.+data QueryOpts a hash range = QueryOpts {+ _qHashKey :: hash+ , _qRangeCondition :: Maybe (RangeOper range)+ , _qFilterCondition :: Maybe (FilterCondition a)+ , _qConsistentRead :: Consistency+ , _qDirection :: Direction+ , _qLimit :: Maybe Natural -- ^ This sets the "D.qLimit" settings for maximum number of evaluated items+ , _qStartKey :: Maybe (hash, range)+ -- ^ Key after which the evaluation starts. When paging, this should be set to qrsLastEvaluatedKey+ -- of the last operation.+}+makeLenses ''QueryOpts+-- | Default settings for query options.+queryOpts :: hash -> QueryOpts a hash range+queryOpts key = QueryOpts key Nothing Nothing Eventually Forward Nothing Nothing++-- | Generate a "D.Query" object+queryCmd :: forall a t v1 v2 hash range rest.+ (TableQuery a t, Code a ~ '[ hash ': range ': rest],+ DynamoScalar v1 hash, DynamoScalar v2 range)+ => QueryOpts a hash range -> D.Query+queryCmd q =+ dQueryKey (Proxy :: Proxy a) (q ^. qHashKey) (q ^. qRangeCondition)+ & D.qConsistentRead . consistencyL .~ (q ^. qConsistentRead)+ & D.qScanIndexForward .~ Just (q ^. qDirection == Forward)+ & D.qLimit .~ (q ^. qLimit)+ & addStartKey (q ^. qStartKey)+ & addCondition (q ^. qFilterCondition)+ where+ addCondition Nothing = id+ addCondition (Just cond) =+ let (expr, attnames, attvals) = dumpCondition cond+ in (D.qExpressionAttributeNames %~ (<> attnames))+ -- HACK; https://github.com/brendanhay/amazonka/issues/332+ . bool (D.qExpressionAttributeValues %~ (<> attvals)) id (null attvals)+ . (D.qFilterExpression .~ Just expr)+ addStartKey Nothing = id+ addStartKey (Just (key, range)) =+ D.qExclusiveStartKey .~ dKeyToAttr (Proxy :: Proxy a) (key, range)++-- | Generic query function. You can query table or indexes that have+-- a range key defined. The filter condition cannot access the hash and range keys.+--+-- Note: see https://github.com/brendanhay/amazonka/issues/340+querySource :: forall a t m v1 v2 hash range rest.+ (TableQuery a t, MonadAWS m, Code a ~ '[ hash ': range ': rest],+ DynamoScalar v1 hash, DynamoScalar v2 range)+ => QueryOpts a hash range -> Source m a+querySource q = paginate (queryCmd q) =$= rsDecode (view D.qrsItems)++-- | Perform a simple, eventually consistent, query.+--+-- Simple to use function to query limited amount of data from database.+querySimple :: forall a t v1 v2 m hash range rest.+ (TableQuery a t, MonadAWS m, Code a ~ '[ hash ': range ': rest],+ DynamoScalar v1 hash, DynamoScalar v2 range)+ => hash -- ^ Hash key+ -> Maybe (RangeOper range) -- ^ Range condition+ -> Direction -- ^ Scan direction+ -> Int -- ^ Maximum number of items to fetch+ -> m [a]+querySimple key range direction limit = do+ let opts = queryOpts key & qRangeCondition .~ range+ & qDirection .~ direction+ fst <$> query opts limit++-- | Query with condition+queryCond :: forall a t v1 v2 m hash range rest.+ (TableQuery a t, MonadAWS m, Code a ~ '[ hash ': range ': rest],+ DynamoScalar v1 hash, DynamoScalar v2 range)+ => hash -- ^ Hash key+ -> Maybe (RangeOper range) -- ^ Range condition+ -> FilterCondition a+ -> Direction -- ^ Scan direction+ -> Int -- ^ Maximum number of items to fetch+ -> m [a]+queryCond key range cond direction limit = do+ let opts = queryOpts key & qRangeCondition .~ range+ & qDirection .~ direction+ & qFilterCondition .~ Just cond+ fst <$> query opts limit++-- | Fetch exactly the required count of items even when+-- it means more calls to dynamodb. Return last evaluted key if end of data+-- was not reached. Use 'qStartKey' to continue reading the query.+query :: forall a t v1 v2 m range hash rest.+ (TableQuery a t, DynamoCollection a 'WithRange t, MonadAWS m, Code a ~ '[ hash ': range ': rest],+ DynamoScalar v1 hash, DynamoScalar v2 range)+ => QueryOpts a hash range+ -> Int -- ^ Maximum number of items to fetch+ -> m ([a], Maybe (PrimaryKey (Code a) 'WithRange))+query opts limit = do+ -- Add qLimit to the opts if not already there - and if there is no condition+ let cmd = queryCmd (opts & addQLimit)+ boundedFetch D.qExclusiveStartKey (view D.qrsItems) (view D.qrsLastEvaluatedKey) cmd limit+ where+ addQLimit+ | Nothing <- opts ^. qLimit, Nothing <- opts ^. qFilterCondition = qLimit .~ Just (fromIntegral limit)+ | otherwise = id++-- | Generic query interface for scanning/querying+boundedFetch :: forall a r t m range hash cmd rest.+ (MonadAWS m, HasPrimaryKey a r t, Code a ~ '[ hash ': range ': rest], AWSRequest cmd)+ => Lens' cmd (HashMap T.Text D.AttributeValue)+ -> (Rs cmd -> [HashMap T.Text D.AttributeValue])+ -> (Rs cmd -> HashMap T.Text D.AttributeValue)+ -> cmd+ -> Int -- ^ Maximum number of items to fetch+ -> m ([a], Maybe (PrimaryKey (Code a) r))+boundedFetch startLens rsResult rsLast startcmd limit = do+ (result, nextcmd) <- unfoldLimit fetch startcmd limit+ if | length result > limit ->+ let final = Seq.take limit result+ in case Seq.viewr final of+ Seq.EmptyR -> return ([], Nothing)+ (_ Seq.:> lastitem) -> return (toList final, Just (dItemToKey lastitem))+ | length result == limit, Just rs <- nextcmd ->+ return (toList result, dAttrToKey (Proxy :: Proxy a) (rs ^. startLens))+ | otherwise -> return (toList result, Nothing)+ where+ fetch cmd = do+ rs <- send cmd+ items <- Seq.fromList <$> mapM rsDecoder (rsResult rs)+ let lastkey = rsLast rs+ newquery = bool (Just (cmd & startLens .~ lastkey)) Nothing (null lastkey)+ return (items, newquery)++unfoldLimit :: Monad m => (cmd -> m (Seq a, Maybe cmd)) -> cmd -> Int -> m (Seq a, Maybe cmd)+unfoldLimit code = go+ where+ go cmd limit = do+ (vals, mnext) <- code cmd+ let cnt = length vals+ if | Just next <- mnext, cnt < limit -> first (vals <>) <$> go next (limit - cnt)+ | otherwise -> return (vals, mnext)++-- | Record for defining scan command. Use lenses to set the content.+--+-- sParallel: (Segment number, Total segments)+data ScanOpts a r = ScanOpts {+ _sFilterCondition :: Maybe (FilterCondition a)+ , _sConsistentRead :: Consistency+ , _sLimit :: Maybe Natural+ , _sParallel :: Maybe (Natural, Natural) -- ^ (Segment number, TotalSegments)+ , _sStartKey :: Maybe (PrimaryKey (Code a) r)+}+makeLenses ''ScanOpts+scanOpts :: ScanOpts a r+scanOpts = ScanOpts Nothing Eventually Nothing Nothing Nothing++-- | Conduit source for running a scan.+--+-- Note: see https://github.com/brendanhay/amazonka/issues/340+scanSource :: (MonadAWS m, TableScan a r t, HasPrimaryKey a r t, Code a ~ '[hash ': range ': xss])+ => ScanOpts a r -> Source m a+scanSource q = paginate (scanCmd q) =$= rsDecode (view D.srsItems)++-- | Function to call bounded scans. Tries to return exactly requested number of items.+--+-- Use 'sStartKey' to continue the scan.+scan :: (MonadAWS m, Code a ~ '[ hash ': range ': rest], TableScan a r t, HasPrimaryKey a r t)+ => ScanOpts a r -- ^ Scan settings+ -> Int -- ^ Required result count+ -> m ([a], Maybe (PrimaryKey (Code a) r)) -- ^ list of results, lastEvalutedKey or Nothing if end of data reached+scan opts limit = do+ let cmd = scanCmd (opts & addSLimit)+ boundedFetch D.sExclusiveStartKey (view D.srsItems) (view D.srsLastEvaluatedKey) cmd limit+ where+ -- If there is no filtercondition, number of processed items = number of scanned items+ addSLimit+ | Nothing <- opts ^. sLimit, Nothing <- opts ^. sFilterCondition = sLimit .~ Just (fromIntegral limit)+ | otherwise = id++-- | Generate a "D.Query" object+scanCmd :: forall a r t hash range xss.+ (TableScan a r t, HasPrimaryKey a r t, Code a ~ '[hash ': range ': xss])+ => ScanOpts a r -> D.Scan+scanCmd q =+ dScan (Proxy :: Proxy a)+ & D.sConsistentRead . consistencyL .~ (q ^. sConsistentRead)+ & D.sLimit .~ (q ^. sLimit)+ & addStartKey (q ^. sStartKey)+ & addCondition (q ^. sFilterCondition)+ & addParallel (q ^. sParallel)+ where+ addCondition Nothing = id+ addCondition (Just cond) =+ let (expr, attnames, attvals) = dumpCondition cond+ in (D.sExpressionAttributeNames %~ (<> attnames))+ -- HACK; https://github.com/brendanhay/amazonka/issues/332+ . bool (D.sExpressionAttributeValues %~ (<> attvals)) id (null attvals)+ . (D.sFilterExpression .~ Just expr)+ --+ addStartKey Nothing = id+ addStartKey (Just pkey) = D.sExclusiveStartKey .~ dKeyToAttr (Proxy :: Proxy a) pkey+ --+ addParallel Nothing = id+ addParallel (Just (segment,total)) =+ (D.sTotalSegments .~ Just total)+ . (D.sSegment .~ Just segment)+++-- | Scan table using a given filter condition.+--+-- > scanCond (colAddress <!:> "Home" <.> colCity ==. "London") 10+-- Note: see https://github.com/brendanhay/amazonka/issues/340+scanCond :: forall a m hash range rest r t.+ (MonadAWS m, HasPrimaryKey a r t, Code a ~ '[ hash ': range ': rest], TableScan a r t)+ => FilterCondition a -> Int -> m [a]+scanCond cond limit = do+ let opts = scanOpts & sFilterCondition .~ Just cond+ runConduit $ scanSource opts =$= CL.take limit
+ src/Database/DynamoDB/TH.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}++-- | Template Haskell macros to automatically derive instances, create column datatypes+-- and create migrations functions.+--+module Database.DynamoDB.TH (+ -- * Derive instances for table and indexes+ -- $table++ -- * Derive instances for nested records+ -- $nested++ -- * Sparse indexes+ -- $sparse++ -- * Main table definition+ mkTableDefs+ , TableConfig(..)+ , tableConfig+ , defaultTranslate+ -- * Nested structures+ , deriveCollection+ , deriveEncodable+ -- * Data types+ , RangeType(..)+) where++import Control.Lens (ix, over, (.~), (^.), _1, view)+import Control.Monad (forM_, when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, tell)+import Data.Char (toUpper)+import Data.Function ((&))+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.HashMap.Strict (HashMap)+import Generics.SOP+import Generics.SOP.TH (deriveGenericOnly)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Name (..), OccName (..))+import Network.AWS.DynamoDB.Types (attributeValue, avM, ProvisionedThroughput, StreamViewType)+import Network.AWS (MonadAWS)++import Database.DynamoDB.Class+import Database.DynamoDB.Migration (runMigration)+import Database.DynamoDB.Types+import Database.DynamoDB.Internal++-- | Configuration of TH macro for creating table instances+data TableConfig = TableConfig {+ tableSetup :: (Name, RangeType, String) -- ^ Table type, primary key type, table name+ , globalIndexes :: [(Name, RangeType, String)] -- ^ Global index type, primary key type, index name+ , localIndexes :: [(Name, String)] -- ^ Local index type, index name+ , translateField :: String -> String -- ^ Translation of haskell field names to DynamoDB attribute names+}++-- | Simple table configuration+tableConfig ::+ (Name, RangeType) -- ^ Table type name, primary key type+ -> [(Name, RangeType)] -- ^ Global secondary index records, index key type+ -> [Name] -- ^ Local secondary index records+ -> TableConfig+tableConfig (table, tbltype) globidx locidx =+ TableConfig {+ tableSetup = (table, tbltype, nameToStr table)+ , globalIndexes = map (\(n,r) -> (n, r, nameToStr n)) globidx+ , localIndexes = map (\n -> (n, nameToStr n)) locidx+ , translateField = defaultTranslate+ }+ where+ nameToStr (Name (OccName name) _) = name++-- | Translates haskell field names to database attribute names. Strips everything up to first '_'.+defaultTranslate :: String -> String+defaultTranslate = translate+ where+ translate ('_':rest) = rest+ translate name+ | '_' `elem` name = drop 1 $ dropWhile (/= '_') name+ | otherwise = name++-- | Create instances, datatypes for table, fields and instances.+--+-- Example of what gets created:+--+-- > data Test { first :: Text, second :: Text, third :: Int }+-- > data TestIndex { third :: Int, second :: T.Text}+-- >+-- > mkTableDefs (tableConfig (''Test, WithRange) [(''TestIndex, NoRange)] [])+-- >+-- > deriveGenericOnly ''Test+-- > instance DynamoCollection Test WithRange IsTable+-- > ...+-- > instance DynamoTable Test WithRange+-- > tableName _ = "Test"+-- >+-- > deriveGenericOnly ''TestIndex+-- > instance DynamoCollection TestIndex NoRange IsIndex+-- > ...+-- > instance DynamoIndex TestIndex Test NoRange IsIndex+-- > indexName _ = "TestIndex"+-- >+-- > data P_First+-- > instance ColumnInfo P_First where+-- > columnName _ = "first"+-- > instance InCollection P_First Test 'NestedPath -- For every attribute+-- > instance InCollection P_Second TestIndex 'FullPath -- For every non-primary attribute+-- > colFirst :: Column Text TypColumn P_First+-- > colFirst = Column+mkTableDefs ::+ String -- ^ Name of the migration function+ -> TableConfig+ -> Q [Dec]+mkTableDefs migname TableConfig{..} =+ execWriterT $ do+ let (table, tblrange, tblname) = tableSetup++ tblFieldNames <- getFieldNames table translateField+ let tblHashName = fst (head tblFieldNames)+ buildColData tblFieldNames+ genBaseCollection table tblrange tblname Nothing translateField++ -- Check, that hash key name in locindexes == hash key in primary table+ forM_ localIndexes $ \(idx, _) -> do+ idxHashName <- (fst . head) <$> getFieldNames idx translateField+ when (idxHashName /= tblHashName) $+ fail ("Hash key " <> show idxHashName <> " in local index " <> show idx+ <> " is not equal to table hash key " <> show tblHashName)++ -- Instances for indices+ let allindexes = globalIndexes ++ map (\(idx,name) -> (idx, WithRange, name)) localIndexes+ forM_ allindexes $ \(idx, idxrange, idxname) -> do+ genBaseCollection idx idxrange idxname (Just table) translateField+ -- Check that all records from indices conform to main table and create instances+ instfields <- getFieldNames idx translateField+ let pkeytable = [True | _ <- [1..(pkeySize idxrange)] ] ++ repeat False+ forM_ (zip instfields pkeytable) $ \((fieldname, ltype), isKey) ->+ case lookup fieldname tblFieldNames of+ Just (AppT (ConT mbtype) inptype)+ | mbtype == ''Maybe && inptype == ltype && isKey -> return () -- Allow sparse index - 'Maybe a' in table, 'a' in index+ Just ptype+ | ltype /= ptype -> fail $ "Record '" <> fieldname <> "' form index " <> show idx <> " has different type from table " <> show table+ <> ": " <> show ltype <> " /= " <> show ptype+ | otherwise -> return ()+ Nothing ->+ fail ("Record '" <> fieldname <> "' from index " <> show idx <> " is not in present in table " <> show table)++ migfunc <- lift $ mkMigrationFunc migname table (map (view _1) globalIndexes) (map (view _1) localIndexes)+ tell migfunc++pkeySize :: RangeType -> Int+pkeySize WithRange = 2+pkeySize NoRange = 1++-- | Generate basic collection instances+genBaseCollection :: Name -> RangeType -> String -> Maybe Name -> (String -> String) -> WriterT [Dec] Q ()+genBaseCollection coll collrange tblname mparent translate = do+ tblFieldNames <- getFieldNames coll translate+ let fieldNames = map fst tblFieldNames+ let fieldList = pure (ListE (map (AppE (VarE 'T.pack) . LitE . StringL) fieldNames))+ primaryList' <- case (collrange, fieldNames) of+ (NoRange, hashname:_) -> return [hashname]+ (WithRange, h:r:_)-> return [h,r]+ _ -> fail "Table must have at least 1/2 fields based on range key"+ let primaryList = pure (ListE (map (AppE (VarE 'T.pack) . LitE . StringL) primaryList'))+ let tbltype = maybe (PromotedT 'IsTable) (const $ PromotedT 'IsIndex) mparent++ lift (deriveGenericOnly coll) >>= tell+ lift [d|+ instance DynamoCollection $(pure (ConT coll)) $(pure (ConT $ mrange collrange)) $(pure tbltype) where+ allFieldNames _ = $(fieldList)+ primaryFields _ = $(primaryList)+ |] >>= tell+ case mparent of+ Nothing ->+ lift [d|+ instance DynamoTable $(pure (ConT coll)) $(pure (ConT $ mrange collrange)) where+ tableName _ = $(pure $ AppE (VarE 'T.pack) (LitE (StringL tblname)))+ |] >>= tell+ Just parent ->+ lift [d|+ instance DynamoIndex $(pure (ConT coll)) $(pure (ConT parent)) $(pure (ConT $ mrange collrange)) where+ indexName _ = $(pure $ AppE (VarE 'T.pack) (LitE (StringL tblname)))+ |] >>= tell++ -- Skip primary key, we cannot filter by it+ let constrNames = mkConstrNames tblFieldNames+ forM_ (drop (pkeySize collrange) constrNames) $ \constr ->+ lift [d|+ instance InCollection $(pure (ConT constr)) $(pure (ConT coll)) 'FullPath+ |] >>= tell+ where+ mrange WithRange = 'WithRange+ mrange NoRange = 'NoRange++-- | Reify name and return list of record fields with type+getFieldNames :: Name -> (String -> String) -> WriterT [Dec] Q [(String, Type)]+getFieldNames tbl translate = do+ info <- lift $ reify tbl+ case getRecords info of+ Left err -> fail $ "Table " <> show tbl <> ": " <> err+ Right lst -> return $ map (over _1 translate) lst+ where+ getRecords :: Info -> Either String [(String, Type)]+#if __GLASGOW_HASKELL__ >= 800+ getRecords (TyConI (DataD _ _ _ _ [RecC _ vars] _)) = Right $ map (\(Name (OccName rname) _,_,typ) -> (rname, typ)) vars+#else+ getRecords (TyConI (DataD _ _ _ [RecC _ vars] _)) = Right $ map (\(Name (OccName rname) _,_,typ) -> (rname, typ)) vars+#endif+ getRecords _ = Left "not a record declaration with 1 constructor"++toConstrName :: String -> String+toConstrName = ("P_" <>) . over (ix 0) toUpper++mkConstrNames :: [(String,a)] -> [Name]+mkConstrNames = map (mkName . toConstrName . fst)++-- | Build P_Column0 data, add it to instances and make colColumn variable+buildColData :: [(String, Type)] -> WriterT [Dec] Q ()+buildColData fieldlist = do+ let constrNames = mkConstrNames fieldlist+ forM_ (zip fieldlist constrNames) $ \((fieldname, ltype), constr) -> do+ let pat = mkName (toPatName fieldname)+#if __GLASGOW_HASKELL__ >= 800+ say $ DataD [] constr [] Nothing [] []+#else+ say $ DataD [] constr [] [] []+#endif+ lift [d|+ instance ColumnInfo $(pure (ConT constr)) where+ columnName _ = T.pack fieldname+ |] >>= tell+ say $ SigD pat (AppT (AppT (AppT (ConT ''Column) ltype) (ConT 'TypColumn)) (ConT constr))+ say $ ValD (VarP pat) (NormalB (VarE 'mkColumn)) []+ where+ toPatName = ("col" <> ) . over (ix 0) toUpper++say :: Monad m => t -> WriterT [t] m ()+say a = tell [a]++-- | Derive 'DynamoEncodable' and prepare column instances for nested structures.+deriveCollection :: Name -> (String -> String) -> Q [Dec]+deriveCollection table translate =+ execWriterT $ do+ lift (deriveGenericOnly table) >>= tell+ -- Create column data+ tblFieldNames <- getFieldNames table translate+ buildColData tblFieldNames+ -- Create instance DynamoEncodable+ deriveEncodable table translate++-- | Derive just the 'DynamoEncodable' instance+-- for structures that were already derived using 'mkTableDefs'+-- and you want to use them as nested structures as well.+--+-- Creates:+--+-- > instance DynamoEncodable Type where+-- > dEncode val = Just (attributeValue & avM .~ gdEncodeG [fieldnames] val)+-- > dDecode (Just attr) = gdDecodeG [fieldnames] (attr ^. avM)+-- > dDecode Nothing = Nothing+-- > instance InCollection column_type P_Column1 'NestedPath+-- > instance InCollection column_type P_Column2 'NestedPath+-- > ...+deriveEncodable :: Name -> (String -> String) -> WriterT [Dec] Q ()+deriveEncodable table translate = do+ tblFieldNames <- getFieldNames table translate+ let fieldList = pure (ListE (map (AppE (VarE 'T.pack) . LitE . StringL . fst) tblFieldNames))+ lift [d|+ instance DynamoEncodable $(pure (ConT table)) where+ dEncode val = Just (attributeValue & avM .~ gsEncodeG $(fieldList) val)+ dDecode (Just attr) = gsDecodeG $(fieldList) (attr ^. avM)+ dDecode Nothing = Nothing+ |] >>= tell+ let constrs = mkConstrNames tblFieldNames+ forM_ constrs $ \constr ->+ lift [d|+ instance InCollection $(pure (ConT constr)) $(pure (ConT table)) 'NestedPath+ |] >>= tell++-- | Creates top-leval variable as a call to a migration function with partially applied createIndex+mkMigrationFunc :: String -> Name -> [Name] -> [Name] -> Q [Dec]+mkMigrationFunc name table globindexes locindexes = do+ let glMap = ListE (map glIdxTemplate globindexes)+ locMap = ListE (map locIdxTemplate locindexes)+ let funcname = mkName name+ m <- newName "m"+ let signature = SigD funcname (ForallT [PlainTV m] [AppT (ConT ''MonadAWS) (VarT m)]+ (AppT (AppT ArrowT (AppT (AppT (ConT ''HashMap) (ConT ''T.Text))+ (ConT ''ProvisionedThroughput)))+ (AppT (AppT ArrowT (AppT (ConT ''Maybe) (ConT ''StreamViewType)))+ (AppT (VarT m) (TupleT 0)))))+ return [signature, ValD (VarP funcname) (NormalB (AppE (AppE (AppE (VarE 'runMigration)+ (SigE (ConE 'Proxy)+ (AppT (ConT ''Proxy)+ (ConT table)))) glMap) locMap)) []]+ where+ glIdxTemplate idx = AppE (VarE 'createGlobalIndex) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT idx)))+ locIdxTemplate idx = AppE (VarE 'createLocalIndex) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT idx)))++-- $table+--+-- Use 'mkTableDefs' to derive everything about a table and its indexes. After running the function,+-- you will end up with lots of instances, data types for columns ('P_TId', 'P_TBase', 'P_TDescr')+-- and smart constructors for column ('colTId', 'colTBase', 'colTDescr', etc.) and one function (migrate)+-- that creates table and updates the indexes.+--+-- The migration function has signature:+--+-- > MonadAWS m => HashMap T.Text ProvisionedThroughput -> Maybe StreamViewType -> m0 ()+--+-- * Table by default equals name of the type.+-- * Attribute name is a field name from a first underscore ('tId'). This should make it compatibile with lens.+-- * Column name is capitalized attribute name with prepended 'col' ('colTId')+-- * Attribute names in an index table must be the same as Attribute names in the main table+-- * Auxiliary datatype for column is P_ followed by capitalized attribute name ('P_TId')+--+-- @+-- data Test = Test {+-- _tId :: Int+-- , _tBase :: T.Text+-- , _tDescr :: T.Text+-- , _tDate :: T.Text+-- , _tDict :: HashMap T.Text Inner+-- } deriving (Show, GHC.Generic)+--+-- data TestIndex = TestIndex {+-- , i_tDate :: T.Text+-- , i_tDescr :: T.Text+-- } deriving (Show, GHC.Generic)+-- mkTableDefs "migrate" (tableConfig (''Test, WithRange) [(''TestIndex, NoRange)] [])+-- @+--++-- $nested+--+-- Use 'deriveCollection' for records that are nested. Use 'deriveEncodable' for records that are+-- nested in one table and serve as its own table at the same time.+--+-- @+-- data Book = Book {+-- author :: T.Text+-- , title :: T.Text+-- } deriving (Show)+-- $(deriveCollection ''Book defaultTranslate)+--+-- data Test = Test {+-- _tId :: Int+-- , _tBase :: T.Text+-- , _tBooks :: [Book]+-- } deriving (Show)+-- mkTableDefs "migrate" (tableConfig (''Test, WithRange) [] [])+-- @++-- $sparse+-- Define sparse index by defining the attribute as "Maybe" in the main table and+-- directly in the index table.+--+-- @+-- data Table {+-- hashKey :: UUID+-- , published :: Maybe UTCTime+-- , ...+-- }+-- data PublishedIndex {+-- published :: UTCTime+-- , hashKey :: UUID+-- , ...+-- }+-- mkTableDefs "migrate" (tableConfig (''Table, NoRange) [(''PublishedIndex, NoRange)] [])+-- @+--
+ src/Database/DynamoDB/Types.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+module Database.DynamoDB.Types (+ -- * Exceptions+ DynamoException(..)+ -- * Marshalling+ , DynamoEncodable(..)+ , DynamoScalar(..)+ , ScalarValue(..)+ , IsText(..), IsNumber+ -- * Query datatype+ , RangeOper(..)+ -- * Utility functions+ , dType+ , dScalarEncode+) where++import Control.Exception (Exception)+import Control.Lens ((.~), (^.))+import qualified Data.Aeson as AE+import qualified Data.ByteString as BS+import Data.ByteString.Lazy (toStrict)+import Data.Double.Conversion.Text (toShortest)+import Data.Foldable (toList)+import Data.Function ((&))+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.Maybe (mapMaybe)+import Data.Proxy+import Data.Scientific (Scientific, floatingOrInteger,+ fromFloatDigits, toBoundedInteger,+ toRealFloat)+import qualified Data.Set as Set+import Data.Tagged (Tagged (..), unTagged)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Data.Vector as V+import Network.AWS.DynamoDB.Types (AttributeValue,+ ScalarAttributeType,+ attributeValue)+import qualified Network.AWS.DynamoDB.Types as D+import Text.Read (readMaybe)+++-- | Exceptions thrown by some dynamodb-simple actions.+data DynamoException = DynamoException T.Text+ deriving (Show)+instance Exception DynamoException++-- | Datatype for encoding scalar values+data ScalarValue (v :: D.ScalarAttributeType) where+ ScS :: !T.Text -> ScalarValue 'D.S+ ScN :: !Scientific -> ScalarValue 'D.N+ ScB :: !BS.ByteString -> ScalarValue 'D.B++class ScalarAuto (v :: D.ScalarAttributeType) where+ dTypeV :: Proxy v -> ScalarAttributeType+ dSetEncodeV :: [ScalarValue v] -> AttributeValue+ dSetDecodeV :: AttributeValue -> Maybe [ScalarValue v]+instance ScalarAuto 'D.S where+ dTypeV _ = D.S+ dSetEncodeV lst = attributeValue & D.avSS .~ map (\(ScS txt) -> txt) lst+ dSetDecodeV attr = Just $ map ScS $ attr ^. D.avSS+instance ScalarAuto 'D.N where+ dTypeV _ = D.N+ dSetEncodeV lst = attributeValue & D.avNS .~ map (\(ScN num) -> decodeUtf8 (toStrict $ AE.encode num)) lst+ dSetDecodeV attr = traverse (\n -> ScN <$> AE.decodeStrict (encodeUtf8 n)) (attr ^. D.avSS)+instance ScalarAuto 'D.B where+ dTypeV _ = D.B+ dSetEncodeV lst = attributeValue & D.avBS .~ map (\(ScB txt) -> txt) lst+ dSetDecodeV attr = Just $ map ScB $ attr ^. D.avBS++dType :: forall a v. DynamoScalar v a => Proxy a -> ScalarAttributeType+dType _ = dTypeV (Proxy :: Proxy v)++dScalarEncode :: DynamoScalar v a => a -> AttributeValue+dScalarEncode a =+ case scalarEncode a of+ ScS txt -> attributeValue & D.avS .~ Just txt+ ScN num -> attributeValue & D.avN .~ Just (decodeUtf8 (toStrict $ AE.encode num))+ ScB bs -> attributeValue & D.avB .~ Just bs++dSetEncode :: DynamoScalar v a => Set.Set a -> AttributeValue+dSetEncode vset = dSetEncodeV $ map scalarEncode $ toList vset++dSetDecode :: (Ord a, DynamoScalar v a) => AttributeValue -> Maybe (Set.Set a)+dSetDecode attr = dSetDecodeV attr >>= traverse scalarDecode >>= pure . Set.fromList++-- | Typeclass signifying that this is a scalar attribute and can be used as a hash/sort key.+--+-- > instance DynamoScalar Network.AWS.DynamoDB.Types.S T.Text where+-- > scalarEncode = ScS+-- > scalarDecode (ScS txt) = Just txt+class (ScalarAuto v, DynamoEncodable a) => DynamoScalar (v :: D.ScalarAttributeType) a | a -> v where+ -- | Scalars must have total encoding function+ scalarEncode :: a -> ScalarValue v+ default scalarEncode :: (Show a, Read a) => a -> ScalarValue 'D.S+ scalarEncode = ScS . T.pack . show++ scalarDecode :: ScalarValue v -> Maybe a+ default scalarDecode :: (Show a, Read a) => ScalarValue 'D.S -> Maybe a+ scalarDecode (ScS txt) = readMaybe (T.unpack txt)++instance DynamoScalar 'D.N Integer where+ scalarEncode = ScN . fromIntegral+ scalarDecode (ScN num) =+ case floatingOrInteger num :: Either Double Integer of+ Right x -> Just x+ Left _ -> Nothing++instance DynamoScalar 'D.N Int where+ scalarEncode = ScN . fromIntegral+ scalarDecode (ScN num) = toBoundedInteger num++instance DynamoScalar 'D.N Word where+ scalarEncode = ScN . fromIntegral+ scalarDecode (ScN num) = toBoundedInteger num++-- | Helper for tagged values+instance DynamoScalar v a => DynamoScalar v (Tagged x a) where+ scalarEncode = scalarEncode . unTagged+ scalarDecode a = Tagged <$> scalarDecode a++-- | Double as a primary key isn't generally a good thing as equality on double+-- is sometimes a little dodgy. Use scientific instead.+instance DynamoScalar 'D.N Scientific where+ scalarEncode = ScN+ scalarDecode (ScN num) = Just num++-- | Don't use Double as a part of primary key in a table. It is included here+-- for convenience to be used as a range key in indexes.+instance DynamoScalar 'D.N Double where+ scalarEncode = ScN . fromFloatDigits+ scalarDecode (ScN num) = Just $ toRealFloat num++instance DynamoScalar 'D.S T.Text where+ scalarEncode = ScS+ scalarDecode (ScS txt) = Just txt++instance DynamoScalar 'D.B BS.ByteString where+ scalarEncode = ScB+ scalarDecode (ScB bs) = Just bs++-- | Typeclass showing that this datatype can be saved to DynamoDB.+class DynamoEncodable a where+ -- | Encode data. Return 'Nothing' if attribute should be omitted.+ dEncode :: a -> Maybe AttributeValue+ default dEncode :: (Show a, Read a) => a -> Maybe AttributeValue+ dEncode val = Just $ attributeValue & D.avS .~ (Just $ T.pack $ show val)+ -- | Decode data. Return 'Nothing' on parsing error, gets+ -- 'Nothing' on input if the attribute was missing in the database.+ dDecode :: Maybe AttributeValue -> Maybe a+ default dDecode :: (Show a, Read a) => Maybe AttributeValue -> Maybe a+ dDecode (Just attr) = attr ^. D.avS >>= (readMaybe . T.unpack)+ dDecode Nothing = Nothing+ -- | Aid for searching for empty list and hashmap; these can be represented+ -- both by empty list and by missing value, if this returns true, enhance search.+ dIsMissing :: a -> Bool+ dIsMissing _ = False++instance DynamoEncodable Scientific where+ dEncode = Just . dScalarEncode+ dDecode (Just attr) = attr ^. D.avN >>= AE.decodeStrict . encodeUtf8+ dDecode Nothing = Nothing -- Fail on missing attr+instance DynamoEncodable Integer where+ dEncode = Just . dScalarEncode+ dDecode (Just attr) = attr ^. D.avN >>= AE.decodeStrict . encodeUtf8+ dDecode Nothing = Nothing -- Fail on missing attr+instance DynamoEncodable Int where+ dEncode = Just . dScalarEncode+ dDecode (Just attr) = attr ^. D.avN >>= AE.decodeStrict . encodeUtf8+ dDecode Nothing = Nothing -- Fail on missing attr+instance DynamoEncodable Word where+ dEncode = Just . dScalarEncode+ dDecode (Just attr) = attr ^. D.avN >>= AE.decodeStrict . encodeUtf8+ dDecode Nothing = Nothing -- Fail on missing attr+instance DynamoEncodable Double where+ dEncode num = Just $ attributeValue & D.avN .~ (Just $ toShortest num)+ dDecode (Just attr) = attr ^. D.avN >>= AE.decodeStrict . encodeUtf8+ dDecode Nothing = Nothing -- Fail on missing attr+instance DynamoEncodable Bool where+ dEncode b = Just $ attributeValue & D.avBOOL .~ Just b+ dDecode (Just attr) = attr ^. D.avBOOL+ dDecode Nothing = Nothing+instance DynamoEncodable T.Text where+ dEncode "" = Nothing+ dEncode txt = Just (dScalarEncode txt)+ dDecode (Just attr)+ | Just True <- attr ^. D.avNULL = Just ""+ | otherwise = attr ^. D.avS+ dDecode Nothing = Just ""+instance DynamoEncodable BS.ByteString where+ dEncode "" = Nothing+ dEncode bs = Just (dScalarEncode bs)+ dDecode (Just attr) = attr ^. D.avB+ dDecode Nothing = Just ""++-- | 'Maybe' ('Maybe' a) will not work well; it will 'join' the value in the database.+instance DynamoEncodable a => DynamoEncodable (Maybe a) where+ dEncode Nothing = Nothing+ dEncode (Just key) = dEncode key+ dDecode Nothing = Just Nothing+ dDecode (Just attr) = Just <$> dDecode (Just attr)+instance (Ord a, DynamoScalar v a) => DynamoEncodable (Set.Set a) where+ dEncode (Set.null -> True) = Nothing+ dEncode dta = Just $ dSetEncode dta+ dDecode (Just attr) = dSetDecode attr+ dDecode Nothing = Just Set.empty+instance (IsText t, DynamoEncodable a) => DynamoEncodable (HashMap t a) where+ dEncode dta =+ let textmap = HMap.fromList $ mapMaybe (\(key, val) -> (toText key,) <$> dEncode val) $ HMap.toList dta+ in Just $ attributeValue & D.avM .~ textmap+ dDecode (Just attr) =+ let attrlist = traverse (\(key, val) -> (fromText key,) <$> dDecode (Just val)) $ HMap.toList (attr ^. D.avM)+ in HMap.fromList <$> attrlist+ dDecode Nothing = Just mempty+ dIsMissing = null+-- | DynamoDB cannot represent empty items; ['Maybe' a] will lose Nothings.+instance DynamoEncodable a => DynamoEncodable [a] where+ dEncode lst = Just $ attributeValue & D.avL .~ mapMaybe dEncode lst+ dDecode (Just attr) = traverse (dDecode . Just) (attr ^. D.avL)+ dDecode Nothing = Just mempty+ dIsMissing = null++instance DynamoEncodable a => DynamoEncodable (Tagged v a) where+ dEncode = dEncode . unTagged+ dDecode a = Tagged <$> dDecode a+ dIsMissing = dIsMissing . unTagged++-- | Partial encoding/decoding Aeson values. Empty strings get converted to NULL.+instance DynamoEncodable AE.Value where+ dEncode (AE.Object obj) = dEncode obj+ dEncode (AE.Array lst) = dEncode (toList lst)+ dEncode (AE.String txt) = dEncode txt+ dEncode num@(AE.Number _) = Just $ attributeValue & D.avN .~ Just (decodeUtf8 (toStrict $ AE.encode num))+ dEncode (AE.Bool b) = dEncode b+ dEncode AE.Null = Just $ attributeValue & D.avNULL .~ Just True+ --+ dDecode Nothing = Just AE.Null+ dDecode (Just attr) = -- Ok, this is going to be very hacky...+ case AE.toJSON attr of+ AE.Object obj -> case HMap.toList obj of+ [("BOOL", AE.Bool val)] -> Just (AE.Bool val)+ [("L", _)] -> (AE.Array .V.fromList) <$> mapM (dDecode . Just) (attr ^. D.avL)+ [("M", _)] -> AE.Object <$> mapM (dDecode . Just) (attr ^. D.avM)+ [("N", AE.String num)] -> AE.decodeStrict (encodeUtf8 num)+ [("N", num@(AE.Number _))] -> Just num -- Just in case, this is usually not returned+ [("S", AE.String val)] -> Just (AE.String val)+ [("NULL", _)] -> Just AE.Null+ _ -> Nothing+ _ -> Nothing -- This shouldn't happen+ --+ dIsMissing AE.Null = True+ dIsMissing _ = False++-- | Class to limit +=. and -=. for updates.+class IsNumber a+instance IsNumber Int+instance IsNumber Double+instance IsNumber Integer+instance IsNumber a => IsNumber (Tagged t a)++-- | Class to limit certain operations to text-like only in queries.+-- Members of this class can be keys to 'HashMap'.+class (Eq a, Hashable a) => IsText a where+ toText :: a -> T.Text+ fromText :: T.Text -> a+instance IsText T.Text where+ toText = id+ fromText = id+instance (Hashable (Tagged t a), IsText a) => IsText (Tagged t a) where+ toText (Tagged txt) = toText txt+ fromText tg = Tagged (fromText tg)++-- | Operation on range key for 'Database.DynamoDB.query'.+data RangeOper a where+ RangeEquals :: a -> RangeOper a+ RangeLessThan :: a -> RangeOper a+ RangeLessThanE :: a -> RangeOper a+ RangeGreaterThan :: a -> RangeOper a+ RangeGreaterThanE :: a -> RangeOper a+ RangeBetween :: a -> a -> RangeOper a+ RangeBeginsWith :: (IsText a) => a -> RangeOper a
+ src/Database/DynamoDB/Update.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Module for creating update actions+--+-- Example as used in nested structure for scan:+--+-- > updateItemByKey_ (Proxy :: Proxy Test, ("hashkey", "sortkey"))+-- > ((colIInt +=. 5) <> (colIText =. "updated") <> (colIMText =. Nothing))+--+-- The unique "Action" can be added together using the '<>' operator. You are not supposed+-- to operate on the same attribute simultaneously using multiple actions.+module Database.DynamoDB.Update (+ Action+ -- * Update action+ , (+=.), (-=.), (=.)+ , setIfNothing+ , append, prepend+ , add, delete+ , delListItem+ , delHashKey+ -- * Utility function+ , dumpActions+) where++import Control.Lens (over, _1)+import Control.Monad.Supply (Supply, evalSupply, supply)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.Semigroup+import qualified Data.Set as Set+import qualified Data.Text as T+import Network.AWS.DynamoDB.Types (AttributeValue)++import Database.DynamoDB.Internal+import Database.DynamoDB.Types++data ActionValue =+ ValAttr AttributeValue+ | IfNotExists NameGen AttributeValue+ | ListAppend NameGen AttributeValue+ | ListPrepend NameGen AttributeValue+ | Plus NameGen AttributeValue -- Add number to existing value+ | Minus NameGen AttributeValue -- Subtract number from existing value++-- | An action for 'Database.DynamoDB.updateItemByKey' functions.+newtype Action t = Action ([Set], [Add], [Delete], [Remove])+ deriving (Semigroup, Monoid)++isNoopAction :: Action t -> Bool+isNoopAction (Action ([], [], [], [])) = True+isNoopAction _ = False++data Set = Set NameGen ActionValue -- General SET+data Add = Add NameGen AttributeValue -- Add value to a Set+data Delete = Delete NameGen AttributeValue -- Delete value from a Set+data Remove = Remove NameGen -- For Maybe types, remove attribute++class ActionClass a where+ dumpAction :: a -> Supply T.Text (T.Text, HashMap T.Text T.Text, HashMap T.Text AttributeValue)+ asAction :: a -> Action t+instance ActionClass Set where+ asAction a = Action ([a], [], [], [])+ dumpAction (Set name val) = do+ (subst, attrnames) <- name supplyName+ (expr, exprattr, valnames) <- mkActionVal val+ return (subst <> " = " <> expr, attrnames <> exprattr, valnames)+instance ActionClass Add where+ asAction a = Action ([], [a], [], [])+ dumpAction (Add name val) = do+ (subst, attrnames) <- name supplyName+ idval <- supplyValue+ let valnames = HMap.singleton idval val+ return (subst <> " " <> idval, attrnames, valnames)+instance ActionClass Delete where+ asAction a = Action ([], [], [a], [])+ dumpAction (Delete name val) = do+ (subst, attrnames) <- name supplyName+ idval <- supplyValue+ let valnames = HMap.singleton idval val+ return (subst <> " " <> idval, attrnames, valnames)+instance ActionClass Remove where+ asAction a = Action ([], [], [], [a])+ dumpAction (Remove name) = do+ (subst, attrnames) <- name supplyName+ return (subst, attrnames, HMap.empty)+++-- | Generate an action expression and associated structures from a list of actions+dumpActions :: Action t -> Maybe (T.Text, HashMap T.Text T.Text, HashMap T.Text AttributeValue)+dumpActions action@(Action (iset, iadd, idelete, iremove))+ | isNoopAction action = Nothing+ | otherwise = Just $ evalSupply eval nameSupply+ where+ eval :: Supply T.Text (T.Text, HashMap T.Text T.Text, HashMap T.Text AttributeValue)+ eval = do+ dset <- mksection "SET" <$> mapM dumpAction iset+ dadd <- mksection "ADD" <$> mapM dumpAction iadd+ ddelete <- mksection "DELETE" <$> mapM dumpAction idelete+ dremove <- mksection "REMOVE" <$> mapM dumpAction iremove+ return $ dset <> dadd <> ddelete <> dremove+ mksection :: T.Text -> [(T.Text, HashMap T.Text T.Text, HashMap T.Text AttributeValue)] -> (T.Text, HashMap T.Text T.Text, HashMap T.Text AttributeValue)+ mksection _ [] = ("", HMap.empty, HMap.empty)+ mksection secname xs =+ let (exprs, attnames, attvals) = mconcat $ map (over _1 (: [])) xs+ in (" " <> secname <> " " <> T.intercalate "," exprs, attnames, attvals)+ nameSupply = map (\i -> T.pack ("A" <> show i)) ([1..] :: [Int])+++supplyName :: Supply T.Text T.Text+supplyName = ("#" <>) <$> supply+supplyValue :: Supply T.Text T.Text+supplyValue = (":" <> ) <$> supply+++mkActionVal :: ActionValue -> Supply T.Text (T.Text, HashMap T.Text T.Text, HashMap T.Text AttributeValue)+mkActionVal (ValAttr val) = do+ valname <- supplyValue+ return (valname, HMap.empty, HMap.singleton valname val)+mkActionVal (IfNotExists name val) = do+ valname <- supplyValue+ (subst, attrnames) <- name supplyName+ return ("if_not_exists(" <> subst <> "," <> valname <> ")", attrnames, HMap.singleton valname val)+mkActionVal (ListAppend name val) = do+ valname <- supplyValue+ (subst, attrnames) <- name supplyName+ return ("list_append(" <> subst <> "," <> valname <> ")", attrnames, HMap.singleton valname val)+mkActionVal (ListPrepend name val) = do+ valname <- supplyValue+ (subst, attrnames) <- name supplyName+ return ("list_append(" <> valname <> "," <> subst <> ")", attrnames, HMap.singleton valname val)+mkActionVal (Plus name val) = do+ valname <- supplyValue+ (subst, attrnames) <- name supplyName+ return (subst <> "+" <> valname, attrnames, HMap.singleton valname val)+mkActionVal (Minus name val) = do+ valname <- supplyValue+ (subst, attrnames) <- name supplyName+ return (subst <> "-" <> valname, attrnames, HMap.singleton valname val)++-- | Add a number to a saved attribute.+(+=.) :: (InCollection col tbl 'FullPath, DynamoScalar v typ, IsNumber typ)+ => Column typ 'TypColumn col -> typ -> Action tbl+(+=.) col val = asAction $ Set (nameGen col) (Plus (nameGen col) (dScalarEncode val))+infix 4 +=.++-- | Subtract a number from a saved attribute.+(-=.) :: (InCollection col tbl 'FullPath, DynamoScalar v typ, IsNumber typ)+ => Column typ 'TypColumn col -> typ -> Action tbl+(-=.) col val = asAction $ Set (nameGen col) (Minus (nameGen col) (dScalarEncode val))+infix 4 -=.++-- | Set an attribute to a new value.+(=.) :: (InCollection col tbl 'FullPath, DynamoEncodable typ)+ => Column typ 'TypColumn col -> typ -> Action tbl+(=.) col val =+ case dEncode val of+ Just attr -> asAction $ Set (nameGen col) (ValAttr attr)+ Nothing -> asAction $ Remove (nameGen col)+infix 4 =.++-- | Set on a Maybe type, if it was not set before.+setIfNothing :: (InCollection col tbl 'FullPath, DynamoEncodable typ)+ => Column (Maybe typ) 'TypColumn col -> typ -> Action tbl+setIfNothing col val =+ case dEncode val of+ Just attr -> asAction $ Set (nameGen col) (IfNotExists (nameGen col) attr)+ Nothing -> mempty++-- | Append a new value to an end of a list.+append :: (InCollection col tbl 'FullPath, DynamoEncodable typ)+ => Column [typ] 'TypColumn col -> [typ] -> Action tbl+append col val =+ case dEncode val of+ Just attr -> asAction $ Set (nameGen col) (ListAppend (nameGen col) attr)+ Nothing -> mempty++-- | Insert a value to a beginning of a list+prepend :: (InCollection col tbl 'FullPath, DynamoEncodable typ)+ => Column [typ] 'TypColumn col -> [typ] -> Action tbl+prepend col val =+ case dEncode val of+ Just attr -> asAction $ Set (nameGen col) (ListPrepend (nameGen col) attr)+ Nothing -> mempty++-- | Add a new value to a set.+add :: (InCollection col tbl 'FullPath, DynamoEncodable (Set.Set typ))+ => Column (Set.Set typ) 'TypColumn col -> Set.Set typ -> Action tbl+add col val+ | Set.null val = mempty+ | otherwise = maybe mempty (asAction . Add (nameGen col)) (dEncode val)++-- | Remove a value from a set.+delete :: (InCollection col tbl 'FullPath, DynamoEncodable (Set.Set typ))+ => Column (Set.Set typ) 'TypColumn col -> Set.Set typ -> Action tbl+delete col val+ | Set.null val = mempty+ | otherwise = maybe mempty (asAction . Delete (nameGen col)) (dEncode val)++-- | Delete n-th list of an item.+delListItem :: InCollection col tbl 'FullPath+ => Column [typ] 'TypColumn col -> Int -> Action tbl+delListItem col idx = asAction $ Remove (nameGen (col <!> idx))++-- | Delete a key from a map.+delHashKey :: (InCollection col tbl 'FullPath, IsText key)+ => Column (HashMap key typ) 'TypColumn col -> key -> Action tbl+delHashKey col key = asAction $ Remove (nameGen (col <!:> key))
+ test/BaseSpec.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module BaseSpec where++import Control.Exception.Safe (SomeException, catchAny, finally,+ try)+import Control.Lens ((.~))+import Control.Monad.IO.Class (liftIO)+import Data.Conduit (runConduit, (=$=))+import qualified Data.Conduit.List as CL+import Data.Either (isLeft)+import Data.Function ((&))+import Data.List (sort)+import Data.Proxy+import Data.Semigroup ((<>))+import qualified Data.Text as T+import Network.AWS+import Network.AWS.DynamoDB (dynamoDB)+import System.Environment (setEnv)+import System.IO (stdout)+import Test.Hspec++import Database.DynamoDB+import Database.DynamoDB.Filter+import Database.DynamoDB.TH+import Database.DynamoDB.Types (RangeOper (..))+import Database.DynamoDB.Update++data Test = Test {+ iHashKey :: T.Text+ , iRangeKey :: Int+ , iText :: T.Text+ , iBool :: Bool+ , iDouble :: Double+ , iInt :: Int+ , iMText :: Maybe T.Text+} deriving (Show, Eq, Ord)+mkTableDefs "migrateTest" (tableConfig (''Test, WithRange) [] [])++withDb :: Example (IO b) => String -> AWS b -> SpecWith (Arg (IO b))+withDb msg code = it msg runcode+ where+ runcode = do+ setEnv "AWS_ACCESS_KEY_ID" "XXXXXXXXXXXXXX"+ setEnv "AWS_SECRET_ACCESS_KEY" "XXXXXXXXXXXXXXfdjdsfjdsfjdskldfs+kl"+ lgr <- newLogger Debug stdout+ env <- newEnv Discover+ let dynamo = setEndpoint False "localhost" 8000 dynamoDB+ let newenv = env & configure dynamo+ -- & set envLogger lgr+ runResourceT $ runAWS newenv $ do+ deleteTable (Proxy :: Proxy Test) `catchAny` (\_ -> return ())+ migrateTest mempty Nothing+ code `finally` deleteTable (Proxy :: Proxy Test)++spec :: Spec+spec = do+ describe "Basic operations" $ do+ withDb "putItem/getItem works" $ do+ let testitem1 = Test "1" 2 "text" False 3.14 2 Nothing+ testitem2 = Test "2" 3 "text" False 4.15 3 (Just "text")+ putItem testitem1+ putItem testitem2+ it1 <- getItem Strongly ("1", 2)+ it2 <- getItem Strongly ("2", 3)+ liftIO $ Just testitem1 `shouldBe` it1+ liftIO $ Just testitem2 `shouldBe` it2+ withDb "getItemBatch/putItemBatch work" $ do+ let template i = Test (T.pack $ show i) i "text" False 3.14 i Nothing+ newItems = map template [1..300]+ putItemBatch newItems+ --+ let keys = map (snd . itemToKey) newItems+ items <- getItemBatch Strongly keys+ liftIO $ sort items `shouldBe` sort newItems+ withDb "insertItem doesn't overwrite items" $ do+ let testitem1 = Test "1" 2 "text" False 3.14 2 Nothing+ testitem1_ = Test "1" 2 "XXXX" True 3.14 3 Nothing+ insertItem testitem1+ (res :: Either SomeException ()) <- try (insertItem testitem1_)+ liftIO $ res `shouldSatisfy` isLeft+ withDb "scanSource works correctly with sLimit" $ do+ let template i = Test (T.pack $ show i) i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ let squery = scanOpts & sFilterCondition .~ Just (colIInt >. 50)+ & sLimit .~ Just 1+ res <- runConduit $ scanSource squery =$= CL.consume+ liftIO $ res `shouldBe` drop 50 newItems+ withDb "querySource works correctly with qLimit" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ let squery = queryOpts "hashkey" & qFilterCondition .~ Just (colIInt >. 50)+ & qLimit .~ Just 1+ res <- runConduit $ querySource squery =$= CL.consume+ liftIO $ res `shouldBe` drop 50 newItems+ withDb "queryCond works correctly with qLimit" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ items <- queryCond "hashkey" Nothing (colIInt >. 50) Forward 5+ liftIO $ items `shouldBe` drop 50 newItems+ withDb "scanCond works correctly" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ items <- scanCond (colIInt >. 50) 5+ liftIO $ items `shouldBe` drop 50 newItems+ withDb "scan works correctly with qlimit" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ (items, _) <- scan (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (colIInt >. 50)) 5+ liftIO $ items `shouldBe` drop 50 newItems+ withDb "scan works correctly with `valIn`" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ (items, _) <- scan (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (colIInt `valIn` [20..30])) 50+ liftIO $ map iInt items `shouldBe` [20..30]+ withDb "scan works correctly with BETWEEN" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ (items, _) <- scan (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (colIInt `between` (20, 30))) 50+ liftIO $ map iInt items `shouldBe` [20..30]+ withDb "scan works correctly with SIZE" $ do+ let testitem1 = Test "1" 2 "very very very very very long" False 3.14 2 Nothing+ testitem2 = Test "1" 3 "short" False 3.14 2 Nothing+ putItem testitem1+ putItem testitem2+ (items, _) <- scan (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (size colIText >. 10)) 50+ liftIO $ items `shouldBe` [testitem1]+ withDb "querySimple works correctly with RangeOper" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ items <- querySimple "hashkey" (Just $ RangeLessThan 30) Backward 5+ liftIO $ map iRangeKey items `shouldBe` [29,28..25]+ withDb "queryCond works correctly with -1 limit" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems+ (items :: [Test]) <- queryCond "hashkey" Nothing (colIInt >. 50) Backward (-1)+ liftIO $ items `shouldBe` []+ withDb "updateItemByKey works" $ do+ let testitem1 = Test "1" 2 "text" False 3.14 2 (Just "something")+ putItem testitem1+ new1 <- updateItemByKey (itemToKey testitem1)+ ((colIInt +=. 5) <> (colIText =. "updated") <> (colIMText =. Nothing))+ Just new2 <- getItem Strongly (snd (itemToKey testitem1))+ liftIO $ do+ new1 `shouldBe` new2+ iInt new1 `shouldBe` 7+ iText new1 `shouldBe` "updated"+ iMText new1 `shouldBe` Nothing++ withDb "update fails on non-existing item" $ do+ let testitem1 = Test "1" 2 "text" False 3.14 2 (Just "something")+ putItem testitem1+ updateItemByKey_ (Proxy :: Proxy Test, ("1", 2)) (colIBool =. True)+ (res :: Either SomeException ()) <- try $ updateItemByKey_ (Proxy :: Proxy Test, ("2", 3)) (colIBool =. True)+ liftIO $ res `shouldSatisfy` isLeft++ withDb "scan continuation works" $ do+ let template i = Test "hashkey" i "text" False 3.14 i Nothing+ newItems = map template [1..55]+ putItemBatch newItems++ (it1 :: [Test], next) <- scan (scanOpts & sFilterCondition .~ Just (colIInt >. 20)+ & sLimit .~ Just 2) 5+ (it2, _) <- scan (scanOpts & sFilterCondition .~ Just (colIInt >. 20)+ & sLimit .~ Just 1+ & sStartKey .~ next) 5+ liftIO $ map iInt (it1 ++ it2) `shouldBe` [21..30]++ withDb "searching empty strings" $ do+ let testitem1 = Test "1" 2 "" False 3.14 2 Nothing+ let testitem2 = Test "1" 3 "aaa" False 3.14 2 (Just "test")+ putItem testitem1+ putItem testitem2+ (items1 :: [Test]) <- queryCond "1" Nothing (colIText ==. "") Forward 10+ (items2 :: [Test]) <- queryCond "1" Nothing (colIMText ==. Nothing) Forward 10+ liftIO $ items1 `shouldBe` [testitem1]+ liftIO $ items2 `shouldBe` [testitem1]++ withDb "deleting by key" $ do+ let testitem1 = Test "1" 2 "" False 3.14 2 Nothing+ let testitem2 = Test "1" 3 "aaa" False 3.14 2 (Just "test")+ putItem testitem1+ putItem testitem2+ (items :: [Test], _) <- scan scanOpts 10+ deleteItemByKey (itemToKey testitem1)+ deleteItemByKey (itemToKey testitem2)+ (items2 :: [Test], _) <- scan scanOpts 10+ liftIO $ do+ length items `shouldBe` 2+ length items2 `shouldBe` 0+++main :: IO ()+main = hspec spec
+ test/NestedSpec.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}++module NestedSpec where++import Control.Exception.Safe (catchAny, finally)+import Control.Monad.IO.Class (liftIO)+import Control.Lens (set, makeLenses, (^.), (^?), ix, (^..))+import Data.Function ((&))+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.Proxy+import qualified Data.Set as Set+import Data.Tagged+import qualified Data.Text as T+import Network.AWS+import Network.AWS.DynamoDB (dynamoDB)+import System.Environment (setEnv)+import System.IO (stdout)+import Test.Hspec++import Database.DynamoDB+import Database.DynamoDB.Filter+import Database.DynamoDB.TH+import Database.DynamoDB.Update++data TName+type Name = Tagged TName T.Text+instance Hashable Name++data Inner = Inner {+ _nFirst :: T.Text+ , _nSecond :: Maybe Int+ , _nThird :: T.Text+} deriving (Show, Eq)+deriveCollection ''Inner defaultTranslate+makeLenses ''Inner++data Test = Test {+ _iHashKey :: T.Text+ , _iRangeKey :: Int+ , _iInner :: Inner+ , _iMInner :: Maybe Inner+ , _iSet :: Set.Set Name+ , _iList :: [Inner]+ , _iMap :: HashMap Name Inner+} deriving (Show, Eq)+mkTableDefs "migrateTest" (tableConfig (''Test, WithRange) [] [])+makeLenses ''Test++withDb :: Example (IO b) => String -> AWS b -> SpecWith (Arg (IO b))+withDb msg code = it msg runcode+ where+ runcode = do+ setEnv "AWS_ACCESS_KEY_ID" "XXXXXXXXXXXXXX"+ setEnv "AWS_SECRET_ACCESS_KEY" "XXXXXXXXXXXXXXfdjdsfjdsfjdskldfs+kl"+ lgr <- newLogger Debug stdout+ env <- newEnv Discover+ let dynamo = setEndpoint False "localhost" 8000 dynamoDB+ let newenv = env & configure dynamo+ -- & set envLogger lgr+ runResourceT $ runAWS newenv $ do+ deleteTable (Proxy :: Proxy Test) `catchAny` (\_ -> return ())+ migrateTest mempty Nothing+ code `finally` deleteTable (Proxy :: Proxy Test)++spec :: Spec+spec = do+ describe "Nested structures" $ do+ withDb "Save and retrieve" $ do+ let inner1 = Inner "test" (Just 3) "test"+ inner2 = Inner "" Nothing ""+ testitem1 = Test "hash" 1 inner1 (Just inner2) (Set.singleton (Tagged "test")) [inner1] (HMap.singleton "test" inner2)+ testitem2 = Test "hash" 2 inner1 Nothing Set.empty [] HMap.empty+ putItem testitem1+ putItem testitem2+ Just ritem1 <- getItem Strongly ("hash", 1)+ Just ritem2 <- getItem Strongly ("hash", 2)+ liftIO $ testitem1 `shouldBe` ritem1+ liftIO $ testitem2 `shouldBe` ritem2+ withDb "Scan conditions" $ do+ let inner1 = Inner "test" (Just 3) ""+ inner2 = Inner "" Nothing "test"+ testitem1 = Test "hash" 1 inner1 (Just inner2) (Set.singleton (Tagged "test")) [inner1] (HMap.singleton "test" inner2)+ testitem2 = Test "hash" 2 inner2 Nothing Set.empty [] HMap.empty+ putItem testitem1+ putItem testitem2+ --+ items1 <- scanCond (colIInner <.> colNFirst ==. "test") 10+ liftIO $ items1 `shouldBe` [testitem1]+ --+ items2 <- scanCond (colIInner <.> colNFirst ==. "") 10+ liftIO $ items2 `shouldBe` [testitem2]+ --+ items3 <- scanCond (colIMInner <.> colNThird ==. "test") 10+ liftIO $ items3 `shouldBe` [testitem1]+ --+ items4 <- scanCond (colIMInner ==. Nothing) 10+ liftIO $ items4 `shouldBe` [testitem2]+ --+ items5 <- scanCond (colISet `setContains` Tagged "test") 10+ liftIO $ items5 `shouldBe` [testitem1]+ --+ items6 <- scanCond (colIList <!> 0 <.> colNFirst ==. "test") 10+ liftIO $ items6 `shouldBe` [testitem1]+ --+ items7 <- scanCond (colIMap <!:> Tagged "test" <.> colNThird ==. "test") 10+ liftIO $ items7 `shouldBe` [testitem1]++ withDb "Nested updates" $ do+ let inner1 = Inner "test" (Just 3) ""+ inner2 = Inner "" Nothing "test"+ testitem1 = Test "hash" 1 inner1 (Just inner2) (Set.singleton (Tagged "test")) [inner1] (HMap.singleton "test" inner2)+ testitem2 = Test "hash" 2 inner2 Nothing Set.empty [] HMap.empty+ putItem testitem1+ putItem testitem2+ --+ newitem1 <- updateItemByKey (itemToKey testitem1) (colIInner <.> colNFirst =. "updated")+ liftIO $ newitem1 ^. iInner . nFirst `shouldBe` "updated"+ --+ newitem2 <- updateItemByKey (itemToKey testitem1) (add colISet (Set.singleton (Tagged "test2")))+ liftIO $ newitem2 ^. iSet `shouldBe` Set.fromList [Tagged "test", Tagged "test2"]+ --+ newitem3 <- updateItemByKey (itemToKey testitem1) (prepend colIList [inner2, inner1])+ liftIO $ newitem3 ^. iList `shouldBe` [inner2, inner1, inner1]+ --+ newitem4 <- updateItemByKey (itemToKey testitem1) (delListItem colIList 1)+ liftIO $ newitem4 ^. iList `shouldBe` [inner2, inner1]+ --+ newitem5 <- updateItemByKey (itemToKey testitem2) (colIMap <!:> Tagged "test" =. inner1)+ liftIO $ newitem5 ^.. iMap . traverse `shouldBe` [inner1]+ liftIO $ newitem5 ^? iMap . ix (Tagged "test") `shouldBe` Just inner1+ --+ newitem6 <- updateItemByKey (itemToKey testitem2) (delHashKey colIMap (Tagged "test"))+ liftIO $ newitem6 ^. iMap `shouldBe` HMap.empty+++main :: IO ()+main = hspec spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}