From 6720cf33a1fc76449168bbaa2b28e25663424d1e Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 15 Sep 2021 17:28:01 -0700 Subject: [PATCH 1/4] Update core library, most of test suite --- dynamodb-simple.cabal | 6 +- src/Control/Monad/Supply.hs | 2 +- src/Database/DynamoDB.hs | 100 +++++----- src/Database/DynamoDB/BatchRequest.hs | 60 +++--- src/Database/DynamoDB/Class.hs | 78 ++++---- src/Database/DynamoDB/Filter.hs | 2 +- src/Database/DynamoDB/Internal.hs | 2 +- src/Database/DynamoDB/Migration.hs | 255 +++++++++++++------------- src/Database/DynamoDB/QueryRequest.hs | 192 ++++++++++--------- src/Database/DynamoDB/TH.hs | 15 +- src/Database/DynamoDB/THConvert.hs | 2 +- src/Database/DynamoDB/THLens.hs | 2 +- src/Database/DynamoDB/Types.hs | 131 ++++++------- test/BaseSpec.hs | 166 ++++++++--------- 14 files changed, 521 insertions(+), 492 deletions(-) diff --git a/dynamodb-simple.cabal b/dynamodb-simple.cabal index a32cb96..129af8e 100644 --- a/dynamodb-simple.cabal +++ b/dynamodb-simple.cabal @@ -33,8 +33,8 @@ library semigroups, bytestring >= 0.10.8.0, containers, template-haskell, transformers, exceptions, amazonka, monad-loops, conduit, hashable, - amazonka-core, aeson, vector, scientific, - tagged, uuid-types, mtl + aeson, vector, scientific, + tagged, uuid-types, mtl, resourcet -- hspec, safe-exceptions hs-source-dirs: src default-language: Haskell2010 @@ -47,6 +47,6 @@ test-suite spec build-depends: base, dynamodb-simple, hspec, text, lens, transformers, safe-exceptions, amazonka-dynamodb >= 1.6.0, amazonka, conduit, semigroups, hashable, containers, unordered-containers, - tagged + tagged, resourcet default-language: Haskell2010 hs-source-dirs: test diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 7bb3b29..5116abb 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -71,7 +71,7 @@ instance (Monoid w, MonadSupply s m) => MonadSupply s (WriterT w m) where peek = lift peek exhausted = lift exhausted -instance Semigroup a => Semigroup (Supply s a) where +instance Data.Semigroup.Semigroup a => Semigroup (Supply s a) where m1 <> m2 = (<>) <$> m1 <*> m2 instance (Semigroup a, Monoid a) => Monoid (Supply s a) where diff --git a/src/Database/DynamoDB.hs b/src/Database/DynamoDB.hs index fae6a9c..07c21cf 100644 --- a/src/Database/DynamoDB.hs +++ b/src/Database/DynamoDB.hs @@ -88,11 +88,13 @@ module Database.DynamoDB ( , TableScan ) where -import Control.Lens ((%~), (.~), (^.)) +import Control.Lens ((%~), (.~), (?~), (^.)) import Control.Monad (void) import Control.Monad.Catch (throwM) +import Control.Monad.Trans.Resource import Data.Bool (bool) import Data.Function ((&)) +import Data.Maybe (fromMaybe) import Data.Proxy import Data.Semigroup ((<>)) import Network.AWS @@ -113,54 +115,54 @@ import Database.DynamoDB.QueryRequest dDeleteItem :: DynamoTable a r => Proxy a -> PrimaryKey a r -> D.DeleteItem -dDeleteItem p pkey = D.deleteItem (tableName p) & D.diKey .~ dKeyToAttr p pkey +dDeleteItem p pkey = D.newDeleteItem (tableName p) & D.deleteItem_key .~ dKeyToAttr p pkey dGetItem :: DynamoTable a r => Proxy a -> PrimaryKey a r -> D.GetItem -dGetItem p pkey = D.getItem (tableName p) & D.giKey .~ dKeyToAttr p pkey +dGetItem p pkey = D.newGetItem (tableName p) & D.getItem_key .~ 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) +putItem :: (DynamoTable a r, MonadResource m, MonadThrow m) => Env -> a -> m () +putItem env item = void $ send env (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 +insertItem :: forall a r m. (DynamoTable a r, MonadResource m) => Env -> a -> m () +insertItem env 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 + cmd = dPutItem item & D.putItem_expressionAttributeNames ?~ attnames + & D.putItem_conditionExpression ?~ expr + & bool (D.putItem_expressionAttributeValues ?~ attvals) id (null attvals) -- HACK; https://github.com/brendanhay/amazonka/issues/332 + void $ send env 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. (MonadAWS m, DynamoTable a r) => Consistency -> Proxy a -> PrimaryKey a r -> m (Maybe a) -getItem consistency p key = do - let cmd = dGetItem p key & D.giConsistentRead . consistencyL .~ consistency - rs <- send cmd - let result = rs ^. D.girsItem +getItem :: forall m a r. (DynamoTable a r, MonadResource m, MonadThrow m) => Env -> Consistency -> Proxy a -> PrimaryKey a r -> m (Maybe a) +getItem env consistency p key = do + let cmd = dGetItem p key & D.getItem_consistentRead . consistencyL .~ consistency + rs <- send env cmd + let result = fromMaybe mempty (rs ^. D.getItemResponse_item) if | null result -> return Nothing | otherwise -> case dGsDecode result of Right res -> return (Just res) - Left err -> throwM (DynamoException $ "Cannot decode item: " <> err) + Left err -> Control.Monad.Catch.throwM (DynamoException $ "Cannot decode item: " Data.Semigroup.<> err) -- | Delete item from the database by specifying the primary key. -deleteItemByKey :: forall m a r. (MonadAWS m, DynamoTable a r) => Proxy a -> PrimaryKey a r -> m () -deleteItemByKey p pkey = void $ send (dDeleteItem p pkey) +deleteItemByKey :: forall m a r. (DynamoTable a r, MonadResource m) => Env -> Proxy a -> PrimaryKey a r -> m () +deleteItemByKey env p pkey = void $ send env (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. - (MonadAWS m, DynamoTable a r) => Proxy a -> PrimaryKey a r -> FilterCondition a -> m () -deleteItemCondByKey p pkey cond = + (DynamoTable a r, MonadResource m) => Env -> Proxy a -> PrimaryKey a r -> FilterCondition a -> m () +deleteItemCondByKey env 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) + cmd = dDeleteItem p pkey & D.deleteItem_expressionAttributeNames ?~ attnames + & bool (D.deleteItem_expressionAttributeValues ?~ attvals) id (null attvals) -- HACK; https://github.com/brendanhay/amazonka/issues/332 + & D.deleteItem_conditionExpression ?~ expr + in void (send env cmd) -- | Generate update item object; automatically adds condition for existence of primary -- key, so that only existing objects are modified @@ -174,19 +176,19 @@ dUpdateItem p pkey actions mcond = pkeyExists = (AttrExists . nameGenPath . pure . IntraName) (head keyfields) genAction actparams = - D.updateItem (tableName p) & D.uiKey .~ dKeyToAttr p pkey - & addActions actparams - & addCondition (Just pkeyExists <> mcond) + D.newUpdateItem (tableName p) & D.updateItem_key .~ 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) + (D.updateItem_updateExpression ?~ expr) + . (D.updateItem_expressionAttributeNames %~ Just . (<> attnames) . fromMaybe mempty) + . bool (D.updateItem_expressionAttributeValues %~ Just . (<> attvals) . fromMaybe mempty) 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 + in (D.updateItem_conditionExpression ?~ expr) + . (D.updateItem_expressionAttributeNames %~ Just . (<> attnames) . fromMaybe mempty) + . bool (D.updateItem_expressionAttributeValues %~ Just . (<> attvals) . fromMaybe mempty) id (null attvals) -- HACK; https://github.com/brendanhay/amazonka/issues/332 addCondition Nothing = id -- Cannot happen anyway @@ -194,36 +196,36 @@ dUpdateItem p pkey actions mcond = -- -- > updateItem (Proxy :: Proxy Test) (12, "2") (colCount +=. 100) updateItemByKey_ :: forall a m r. - (MonadAWS m, DynamoTable a r) => Proxy a -> PrimaryKey a r -> Action a -> m () -updateItemByKey_ p pkey actions - | Just cmd <- dUpdateItem p pkey actions Nothing = void $ send cmd + (DynamoTable a r, MonadResource m) => Env -> Proxy a -> PrimaryKey a r -> Action a -> m () +updateItemByKey_ env p pkey actions + | Just cmd <- dUpdateItem p pkey actions Nothing = void $ send env cmd | otherwise = return () -- | Update item in a database, return an updated version of the item. updateItemByKey :: forall a m r. - (MonadAWS m, DynamoTable a r) => Proxy a -> PrimaryKey a r -> Action a -> m a -updateItemByKey p pkey actions + (DynamoTable a r, MonadResource m, MonadThrow m) => Env -> Proxy a -> PrimaryKey a r -> Action a -> m a +updateItemByKey env p pkey actions | Just cmd <- dUpdateItem p pkey actions Nothing = do - rs <- send (cmd & D.uiReturnValues .~ Just D.AllNew) - case dGsDecode (rs ^. D.uirsAttributes) of + rs <- send env (cmd & D.updateItem_returnValues ?~ D.ReturnValue_ALL_NEW) + case dGsDecode (fromMaybe mempty (rs ^. D.updateItemResponse_attributes)) of Right res -> return res Left err -> throwM (DynamoException $ "Cannot decode item: " <> err) | otherwise = do - rs <- getItem Strongly p pkey + rs <- getItem env Strongly p 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. (MonadAWS m, DynamoTable a r) - => Proxy a -> PrimaryKey a r -> FilterCondition a -> Action a -> m () -updateItemCond_ p pkey cond actions - | Just cmd <- dUpdateItem p pkey actions (Just cond) = void $ send cmd +updateItemCond_ :: forall a m r. (DynamoTable a r, MonadResource m) + => Env ->Proxy a -> PrimaryKey a r -> FilterCondition a -> Action a -> m () +updateItemCond_ env p pkey cond actions + | Just cmd <- dUpdateItem p pkey actions (Just cond) = void $ send env cmd | otherwise = return () -- | Delete a table from DynamoDB. -deleteTable :: (MonadAWS m, DynamoTable a r) => Proxy a -> m () -deleteTable p = void $ send (D.deleteTable (tableName p)) +deleteTable :: (DynamoTable a r, MonadResource m) => Env -> Proxy a -> m () +deleteTable env p = void $ send env (D.newDeleteTable (tableName p)) -- | Extract primary key from a record. -- @@ -281,7 +283,7 @@ tableKey = dTableKey -- -- Save data to database -- putItem (Test "news" "1-2-3-4" "New subject") -- -- Fetch data given primary key --- item <- getItem Eventually tTest ("news", "1-2-3-4") +-- item <- getItem env Eventually tTest ("news", "1-2-3-4") -- liftIO $ print item -- (item :: Maybe Test) -- -- Scan data using filter condition, return 10 results -- items <- scanCond tTest (subject' ==. "New subejct") 10 diff --git a/src/Database/DynamoDB/BatchRequest.hs b/src/Database/DynamoDB/BatchRequest.hs index 9789fc3..ebde476 100644 --- a/src/Database/DynamoDB/BatchRequest.hs +++ b/src/Database/DynamoDB/BatchRequest.hs @@ -14,14 +14,16 @@ module Database.DynamoDB.BatchRequest ( ) where import Control.Concurrent (threadDelay) -import Control.Lens (at, ix, (.~), (^.), (^..)) +import Control.Lens (at, ix, (.~), (?~), (^.), (^..)) import Control.Monad (unless) import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource import Data.Function ((&)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Proxy import qualified Data.Text as T @@ -39,28 +41,28 @@ 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 +retryWriteBatch :: MonadResource m => Env -> D.BatchWriteItem -> m () +retryWriteBatch env cmd = do + rs <- send env cmd + let unprocessed = fromMaybe mempty (rs ^. D.batchWriteItemResponse_unprocessedItems) unless (null unprocessed) $ do liftIO $ threadDelay 1000000 - retryWriteBatch (cmd & D.bwiRequestItems .~ unprocessed) + retryWriteBatch env (cmd & D.batchWriteItem_requestItems .~ 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 +retryReadBatch :: MonadResource m => Env -> D.BatchGetItem -> m (HashMap T.Text [HashMap T.Text D.AttributeValue]) +retryReadBatch env = go mempty where go previous cmd = do - rs <- send cmd - let unprocessed = rs ^. D.bgirsUnprocessedKeys - result = HMap.unionWith (++) previous (rs ^. D.bgirsResponses) + rs <- send env cmd + let unprocessed = fromMaybe mempty (rs ^. D.batchGetItemResponse_unprocessedKeys) + result = HMap.unionWith (++) previous (fromMaybe mempty (rs ^. D.batchGetItemResponse_responses)) if | null unprocessed -> return result | otherwise -> do liftIO $ threadDelay 1000000 - go result (cmd & D.bgiRequestItems .~ unprocessed) + go result (cmd & D.batchGetItem_requestItems .~ unprocessed) -- | Chunk list according to batch operation limit chunkBatch :: Int -> [a] -> [NonEmpty a] @@ -73,47 +75,47 @@ chunkBatch _ _ = [] -- 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) +putItemBatch :: forall m a r. (MonadResource m, DynamoTable a r) => Env -> [a] -> m () +putItemBatch env 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 + mkrequest item = D.newWriteRequest & D.writeRequest_putRequest ?~ (D.newPutRequest & D.putRequest_item .~ gsEncode item) + cmd = D.newBatchWriteItem & D.batchWriteItem_requestItems . at tblname ?~ wrequests + retryWriteBatch env cmd -- | Get batch of items. -getItemBatch :: forall m a r. (MonadAWS m, DynamoTable a r) => Consistency -> [PrimaryKey a r] -> m [a] -getItemBatch consistency lst = concat <$> mapM go (chunkBatch 100 lst) +getItemBatch :: forall m a r. (MonadResource m, MonadThrow m, DynamoTable a r) => Env -> Consistency -> [PrimaryKey a r] -> m [a] +getItemBatch env 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 + kaas = D.newKeysAndAttributes wkaas & D.keysAndAttributes_consistentRead . consistencyL .~ consistency + cmd = D.newBatchGetItem & D.batchGetItem_requestItems . at tblname ?~ kaas - tbls <- retryReadBatch cmd + tbls <- retryReadBatch env cmd mapM decoder (tbls ^.. ix tblname . traverse) decoder item = case dGsDecode item of Right res -> return res - Left err -> throwM (DynamoException $ "Error decoding item: " <> err ) + Left err -> Control.Monad.Catch.throwM (DynamoException $ "Error decoding item: " Data.Monoid.<> err ) dDeleteRequest :: DynamoTable a r => Proxy a -> PrimaryKey a r -> D.DeleteRequest -dDeleteRequest p pkey = D.deleteRequest & D.drKey .~ dKeyToAttr p pkey +dDeleteRequest p pkey = D.newDeleteRequest & D.deleteRequest_key .~ 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. (MonadAWS m, DynamoTable a r) => Proxy a -> [PrimaryKey a r] -> m () -deleteItemBatchByKey p lst = mapM_ go (chunkBatch 25 lst) +deleteItemBatchByKey :: forall m a r. (MonadResource m, DynamoTable a r) => Env -> Proxy a -> [PrimaryKey a r] -> m () +deleteItemBatchByKey env 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 + mkrequest key = D.newWriteRequest & D.writeRequest_deleteRequest ?~ dDeleteRequest p key + cmd = D.newBatchWriteItem & D.batchWriteItem_requestItems . at tblname ?~ wrequests + retryWriteBatch env cmd diff --git a/src/Database/DynamoDB/Class.hs b/src/Database/DynamoDB/Class.hs index facdfc1..e13f385 100644 --- a/src/Database/DynamoDB/Class.hs +++ b/src/Database/DynamoDB/Class.hs @@ -43,7 +43,7 @@ module Database.DynamoDB.Class ( , ContainsTableKey(..) ) where -import Control.Lens ((.~), sequenceOf, _2) +import Control.Lens ((.~), (?~), sequenceOf, _2) import Data.Bifunctor (first) import Data.Function ((&)) import qualified Data.HashMap.Strict as HMap @@ -56,8 +56,8 @@ 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) + newGlobalSecondaryIndex, + newKeySchemaElement, AttributeValue) import qualified Network.AWS.DynamoDB.Types as D import Data.HashMap.Strict (HashMap) import Data.Maybe (mapMaybe) @@ -247,54 +247,56 @@ gsDecodeG names attrs = in to . SOP . Z <$> hsequence (hcliftA dproxy (decodeWithErr . unK) pairs) where dproxy = Proxy :: Proxy DynamoEncodable - decodeWithErr (k, Nothing) = first (("Error decoding empty attr: " <> k <> " -> ") <>) (dDecodeEither Nothing) + decodeWithErr (k, Nothing) = first (("Error decoding empty attr: " Data.Monoid.<> k <> " -> ") <>) (dDecodeEither Nothing) decodeWithErr (k, Just attr) = first (\err -> "Error decoding attr: " <> k <> " -> " <> err <> " from: " <> T.pack (show attr)) (dDecodeEither (Just attr)) defaultPutItem :: forall a r. DynamoTable a r => a -> D.PutItem -defaultPutItem item = D.putItem tblname & D.piItem .~ gsEncode item +defaultPutItem item = D.newPutItem tblname & D.putItem_item .~ 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 + D.newCreateTable (tableName p) (hashKey :| []) + & D.createTable_provisionedThroughput ?~ thr + & D.createTable_attributeDefinitions .~ keyDefs where hashname = head (allFieldNames p) - hashKey = keySchemaElement hashname D.Hash - keyDefs = [D.attributeDefinition hashname (dType (Proxy :: Proxy hash))] + hashKey = newKeySchemaElement hashname D.KeyType_HASH + keyDefs = [D.newAttributeDefinition 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 + D.newCreateTable (tableName p) (hashKey :| [rangeKey]) + & D.createTable_provisionedThroughput ?~ thr + & D.createTable_attributeDefinitions .~ 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))] + hashKey = newKeySchemaElement hashname D.KeyType_HASH + rangeKey = newKeySchemaElement rangename D.KeyType_RANGE + keyDefs = [D.newAttributeDefinition hashname (dType (Proxy :: Proxy hash)), + D.newAttributeDefinition rangename (dType (Proxy :: Proxy range))] defaultQueryKey :: (CanQuery a t hash range, 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 + D.newQuery (qTableName p) & D.query_keyConditionExpression ?~ "#K = :key" + & D.query_expressionAttributeNames ?~ HMap.singleton "#K" hashname + & D.query_expressionAttributeValues ?~ HMap.singleton ":key" (dScalarEncode key) + & D.query_indexName .~ 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 + D.newQuery (qTableName p) & D.query_keyConditionExpression ?~ condExpression + & D.query_expressionAttributeNames ?~ attrnames + & D.query_expressionAttributeValues ?~ attrvals + & D.query_indexName .~ qIndexName p where rangeSubst = "#R" condExpression = "#K = :key AND " <> rangeOper range rangeSubst @@ -306,15 +308,16 @@ 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) + (newGlobalSecondaryIndex (indexName p) keyschema proj + & D.globalSecondaryIndex_provisionedThroughput ?~ thr, attrdefs) where (hashname:_) = allFieldNames p - attrdefs = [D.attributeDefinition hashname (dType (Proxy :: Proxy hash))] - keyschema = keySchemaElement hashname D.Hash :| [] + attrdefs = [D.newAttributeDefinition hashname (dType (Proxy :: Proxy hash))] + keyschema = newKeySchemaElement hashname D.KeyType_HASH :| [] proj | Just lst <- nonEmpty attrlist = - D.projection & D.pProjectionType .~ Just D.PTInclude - & D.pNonKeyAttributes .~ Just lst - | otherwise = D.projection & D.pProjectionType .~ Just D.PTKeysOnly + D.newProjection & D.projection_projectionType .~ Just D.ProjectionType_INCLUDE + & D.projection_nonKeyAttributes .~ Just lst + | otherwise = D.newProjection & D.projection_projectionType .~ Just D.ProjectionType_KEYS_ONLY parentKey = primaryFields (Proxy :: Proxy parent) attrlist = filter (`notElem` (parentKey ++ [hashname])) $ allFieldNames (Proxy :: Proxy a) @@ -326,14 +329,14 @@ 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)] + attrdefs = [D.newAttributeDefinition hashname (dType hashproxy), D.newAttributeDefinition rangename (dType rangeproxy)] -- - keyschema = keySchemaElement hashname D.Hash :| [keySchemaElement rangename D.Range] + keyschema = newKeySchemaElement hashname D.KeyType_HASH :| [newKeySchemaElement rangename D.KeyType_RANGE] -- proj | Just lst <- nonEmpty attrlist = - D.projection & D.pProjectionType .~ Just D.PTInclude - & D.pNonKeyAttributes .~ Just lst - | otherwise = D.projection & D.pProjectionType .~ Just D.PTKeysOnly + D.newProjection & D.projection_projectionType .~ Just D.ProjectionType_INCLUDE + & D.projection_nonKeyAttributes .~ Just lst + | otherwise = D.newProjection & D.projection_projectionType .~ Just D.ProjectionType_KEYS_ONLY parentKey = primaryFields (Proxy :: Proxy parent) attrlist = filter (`notElem` (parentKey ++ [hashname, rangename])) $ allFieldNames (Proxy :: Proxy a) @@ -342,7 +345,8 @@ defaultCreateGlobalIndexRange :: forall a parent r2 hash rest range v1 v2. 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) + (newGlobalSecondaryIndex (indexName p) keyschema proj + & D.globalSecondaryIndex_provisionedThroughput ?~ thr, attrdefs) where (keyschema, proj, attrdefs) = mkIndexHelper p @@ -351,10 +355,10 @@ createLocalIndex :: forall a parent r2 hash rest range v1 v2. DynamoScalar v1 hash, DynamoScalar v2 range) => Proxy a -> (D.LocalSecondaryIndex, [D.AttributeDefinition]) createLocalIndex p = - (D.localSecondaryIndex (indexName p) keyschema proj, attrdefs) + (D.newLocalSecondaryIndex (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 +defaultScan p = D.newScan (qsTableName p) & D.scan_indexName .~ qsIndexName p diff --git a/src/Database/DynamoDB/Filter.hs b/src/Database/DynamoDB/Filter.hs index 7b7a9c2..942ae05 100644 --- a/src/Database/DynamoDB/Filter.hs +++ b/src/Database/DynamoDB/Filter.hs @@ -77,7 +77,7 @@ dcomp :: (InCollection col tbl 'FullPath, DynamoEncodable typ) 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) + encval = fromMaybe (D.newAttributeValue & D.attributeValue_null .~ Just True) (dEncode val) -- | AND for combining conditions. (&&.) :: FilterCondition t -> FilterCondition t -> FilterCondition t diff --git a/src/Database/DynamoDB/Internal.hs b/src/Database/DynamoDB/Internal.hs index c9e6a43..dc476f3 100644 --- a/src/Database/DynamoDB/Internal.hs +++ b/src/Database/DynamoDB/Internal.hs @@ -63,7 +63,7 @@ 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) + return ("size(" Data.Semigroup.<> 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 diff --git a/src/Database/DynamoDB/Migration.hs b/src/Database/DynamoDB/Migration.hs index 624ec96..6bc98e0 100644 --- a/src/Database/DynamoDB/Migration.hs +++ b/src/Database/DynamoDB/Migration.hs @@ -14,13 +14,13 @@ module Database.DynamoDB.Migration ( import Control.Arrow (first) import Control.Concurrent (threadDelay) import Control.Lens (set, view, (%~), (.~), - (^.), (^..), (^?), _1, + (^.), (^..), (^?), (?~), _1, _Just) import Control.Monad (unless, void, when) -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.Catch (throwM, MonadCatch) +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Loops (whileM_) -import Control.Monad.Trans.AWS (AWSConstraint) +import Control.Monad.Trans.Resource import Data.Bool (bool) import Data.Foldable (toList) import Data.Function ((&)) @@ -42,107 +42,110 @@ 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 +getTableDescription :: (MonadResource m, MonadThrow m) => Env -> T.Text -> m D.TableDescription +getTableDescription env tblname = do + rs <- send env (D.newDescribeTable tblname) + case rs ^? D.describeTableResponse_table . _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 = +waitUntilTableActive :: forall r m. (MonadResource m, MonadThrow m) => Env -> T.Text -> Bool -> m () +waitUntilTableActive env name checkindex = whileM_ tableIsNotActive $ do - logmsg Info $ "Waiting for table " <> name <> " and its indices to become active" + logmsg env 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.TSActive || any (/= D.ISActive) idxstatus) - | otherwise -> return (status /= D.TSActive) + descr <- getTableDescription env name + status <- maybe (throwM (DynamoException "Missing table status")) return (descr ^. D.tableDescription_tableStatus) + let idxstatus = descr ^.. D.tableDescription_globalSecondaryIndexes . _Just . traverse . D.globalSecondaryIndexDescription_indexStatus . _Just + if | checkindex -> return (status /= D.TableStatus_ACTIVE || any (/= D.IndexStatus_ACTIVE) idxstatus) + | otherwise -> return (status /= D.TableStatus_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 +deleteIndices :: forall m. MonadResource m => Env -> T.Text -> [T.Text] -> m () +deleteIndices env tblname indices = do + let idxupdates = map (\name -> set D.globalSecondaryIndexUpdate_delete (Just $ D.newDeleteGlobalSecondaryIndexAction name) D.newGlobalSecondaryIndexUpdate) indices + cmd = D.newUpdateTable tblname & D.updateTable_globalSecondaryIndexUpdates ?~ idxupdates + void $ send env 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 +createIndices :: forall m. MonadResource m => Env -> D.CreateTable -> [D.GlobalSecondaryIndex] -> m () +createIndices env table indices = do + let tblname = table ^. D.createTable_tableName + idxupdates = map (\idx -> set D.globalSecondaryIndexUpdate_create (Just $ mkidx idx) D.newGlobalSecondaryIndexUpdate) indices + cmd = D.newUpdateTable tblname & D.updateTable_globalSecondaryIndexUpdates ?~ idxupdates + & D.updateTable_attributeDefinitions ?~ (table ^. D.createTable_attributeDefinitions) + void $ send env cmd where mkidx :: D.GlobalSecondaryIndex -> D.CreateGlobalSecondaryIndexAction - mkidx idx = D.createGlobalSecondaryIndexAction (idx ^. D.gsiIndexName) (idx ^. D.gsiKeySchema) - (idx ^. D.gsiProjection) (idx ^. D.gsiProvisionedThroughput) + mkidx idx = D.newCreateGlobalSecondaryIndexAction + (idx ^. D.globalSecondaryIndex_indexName) + (idx ^. D.globalSecondaryIndex_keySchema) + (idx ^. D.globalSecondaryIndex_projection) + & D.createGlobalSecondaryIndexAction_provisionedThroughput .~ (idx ^. D.globalSecondaryIndex_provisionedThroughput) -- | 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 + newmap = HMap.fromList $ map (\idx -> (idx ^. D.globalSecondaryIndex_indexName, idx)) newidxes + oldmap = HMap.fromList $ mapMaybe (\idx -> (,idx) <$> idx ^. D.globalSecondaryIndexDescription_indexName) oldidxes -- hasConflict (newidx, oldix) = not (projectionOk newidx oldix && keysOk newidx oldix) - keysOk newidx oldidx = Just (newidx ^. D.gsiKeySchema) == oldidx ^. D.gsidKeySchema + keysOk newidx oldidx = Just (newidx ^. D.globalSecondaryIndex_keySchema) == oldidx ^. D.globalSecondaryIndexDescription_keySchema -- 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.PTKeysOnly || (newprojtype == oldprojtype && newkeys `Set.isSubsetOf` oldkeys) + newprojtype == Just D.ProjectionType_KEYS_ONLY || (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 + newprojtype = newidx ^? D.globalSecondaryIndex_projection . D.projection_projectionType . _Just + oldprojtype = oldidx ^? D.globalSecondaryIndexDescription_projection . _Just . D.projection_projectionType . _Just + newkeys = Set.fromList $ newidx ^.. D.globalSecondaryIndex_projection . D.projection_nonKeyAttributes . _Just . traverse + oldkeys = Set.fromList $ oldidx ^.. D.globalSecondaryIndexDescription_projection . _Just . D.projection_nonKeyAttributes . _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 + map (view (_1 . D.localSecondaryIndex_indexName)) $ 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 + newmap = HMap.fromList $ map (\idx -> (idx ^. D.localSecondaryIndex_indexName, idx)) newidxes + oldmap = HMap.fromList $ mapMaybe (\idx -> (,idx) <$> idx ^. D.localSecondaryIndexDescription_indexName) oldidxes -- hasConflict (newidx, oldix) = not (projectionOk newidx oldix && keysOk newidx oldix) - keysOk newidx oldidx = Just (newidx ^. D.lsiKeySchema) == oldidx ^. D.lsidKeySchema + keysOk newidx oldidx = Just (newidx ^. D.localSecondaryIndex_keySchema) == oldidx ^. D.localSecondaryIndexDescription_keySchema -- Assume the indices were created by this module and we want them exactly the same projectionOk newidx oldidx = - newprojtype == Just D.PTKeysOnly || (newprojtype == oldprojtype && newkeys `Set.isSubsetOf` oldkeys) + newprojtype == Just D.ProjectionType_KEYS_ONLY || (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 + newprojtype = newidx ^? D.localSecondaryIndex_projection . D.projection_projectionType . _Just + oldprojtype = oldidx ^? D.localSecondaryIndexDescription_projection . _Just . D.projection_projectionType . _Just + newkeys = Set.fromList $ newidx ^.. D.localSecondaryIndex_projection . D.projection_nonKeyAttributes . _Just . traverse + oldkeys = Set.fromList $ oldidx ^.. D.localSecondaryIndexDescription_projection . _Just . D.projection_nonKeyAttributes . _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 + newidxlist = fromMaybe mempty (tabledef ^. D.createTable_globalSecondaryIndexes) + oldidxlist = fromMaybe mempty (descr ^. D.tableDescription_globalSecondaryIndexes) + newidxnames = newidxlist ^.. traverse . D.globalSecondaryIndex_indexName + oldidxnames = oldidxlist ^.. traverse . D.globalSecondaryIndexDescription_indexName . _Just -- recreate = findInconsistentIdxes newidxlist oldidxlist - todelete = map (view D.gsiIndexName) recreate ++ (oldidxnames \\ newidxnames) - tocreate = recreate ++ filter (\idx -> idx ^. D.gsiIndexName `notElem` oldidxnames) newidxlist + todelete = map (view D.globalSecondaryIndex_indexName) recreate ++ (oldidxnames \\ newidxnames) + tocreate = recreate ++ filter (\idx -> idx ^. D.globalSecondaryIndex_indexName `notElem` oldidxnames) newidxlist -compareLocalIndexes :: MonadAWS m => D.CreateTable -> D.TableDescription -> m () +compareLocalIndexes :: (MonadResource m, MonadThrow 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 + let newidxlist = fromMaybe mempty (tabledef ^. D.createTable_localSecondaryIndexes) + oldidxlist = fromMaybe mempty (descr ^. D.tableDescription_localSecondaryIndexes) + newidxnames = newidxlist ^.. traverse . D.localSecondaryIndex_indexName + oldidxnames = oldidxlist ^.. traverse . D.localSecondaryIndexDescription_indexName . _Just missing = filter (`notElem` oldidxnames) newidxnames unless (null missing) $ throwM (DynamoException ("Missing local secondary indexes: " <> T.intercalate "," missing)) @@ -152,41 +155,42 @@ compareLocalIndexes tabledef descr = do <> 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) +changeStream :: (MonadResource m, MonadThrow m) + => Env -> T.Text -> Maybe D.StreamSpecification -> Maybe D.StreamSpecification -> m () +changeStream _ _ Nothing Nothing = return () +changeStream env tblname (Just _) Nothing = do + logmsg env Info "Disabling streaming." + waitUntilTableActive env tblname False + let enabled = False + strspec = D.newStreamSpecification enabled + cmd = D.newUpdateTable tblname & D.updateTable_streamSpecification ?~ strspec + void (send env cmd) +changeStream env tblname Nothing (Just new) = do + waitUntilTableActive env tblname False + logmsg env Info "Enabling streaming." + let cmd = D.newUpdateTable tblname & D.updateTable_streamSpecification ?~ new + void (send env cmd) +changeStream env tblname (Just old) (Just new) = do + changeStream env tblname (Just old) Nothing + changeStream env tblname Nothing (Just new) -- | Main table migration code -tryMigration :: (AWSConstraint r m, MonadAWS m) => D.CreateTable -> D.TableDescription -> m () -tryMigration tabledef descr = do +tryMigration :: (MonadResource m, MonadThrow m) => Env -> D.CreateTable -> D.TableDescription -> m () +tryMigration env tabledef descr = do -- Check key schema on the main table, fail if it changed. - let tblkeys = tabledef ^. D.ctKeySchema - oldtblkeys = descr ^. D.tdKeySchema + let tblkeys = tabledef ^. D.createTable_keySchema + oldtblkeys = descr ^. D.tableDescription_keySchema 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 + logmsg env 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 + logmsg env Error msg throwM (DynamoException msg) -- Check that local indexes are in sync with the settings. Fails if inconsistent. @@ -195,87 +199,88 @@ tryMigration tabledef descr = do -- 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 + waitUntilTableActive env tblname False + logmsg env Info $ "Deleting indices: " <> T.intercalate "," todelete + deleteIndices env tblname todelete unless (null tocreate) $ do - waitUntilTableActive tblname True - logmsg Info $ "Create new indices: " <> T.intercalate "," (tocreate ^.. traverse . D.gsiIndexName) - createIndices tabledef tocreate + waitUntilTableActive env tblname True + logmsg env Info $ "Create new indices: " <> T.intercalate "," (tocreate ^.. traverse . D.globalSecondaryIndex_indexName) + createIndices env tabledef tocreate -- Check streaming settings - when (tabledef ^. D.ctStreamSpecification /= descr ^. D.tdStreamSpecification) $ - changeStream tblname (descr ^. D.tdStreamSpecification) (tabledef ^. D.ctStreamSpecification) + when (tabledef ^. D.createTable_streamSpecification /= descr ^. D.tableDescription_streamSpecification) $ + changeStream env tblname (descr ^. D.tableDescription_streamSpecification) (tabledef ^. D.createTable_streamSpecification) -- Done - logmsg Info $ "Table " <> tblname <> " schema check done." + logmsg env Info $ "Table " <> tblname <> " schema check done." where - tblname = tabledef ^. D.ctTableName + tblname = tabledef ^. D.createTable_tableName -- 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) + let attrToTup = (,) <$> view D.attributeDefinition_attributeName <*> view D.attributeDefinition_attributeType + attrdefs = HMap.fromList $ map attrToTup (tabledef ^. D.createTable_attributeDefinitions) + olddefs = HMap.fromList $ map attrToTup (fromMaybe mempty (descr ^. D.tableDescription_attributeDefinitions)) 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 +logmsg :: (MonadIO m) => Env -> LogLevel -> T.Text -> m () +logmsg env level text = do + let logger = envLogger env 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 + tblname = tblinfo ^. D.createTable_tableName + tkeys = T.intercalate "," $ tblinfo ^.. (D.createTable_keySchema . traverse . D.keySchemaElement_attributeName) + idxlist = fromMaybe mempty (tblinfo ^. D.createTable_globalSecondaryIndexes) 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) + printidx idx = idx ^. D.globalSecondaryIndex_indexName <> "(" <> ikeys idx <> ")" + ikeys idx = T.intercalate "," $ idx ^.. (D.globalSecondaryIndex_keySchema . traverse . D.keySchemaElement_attributeName) -createOrMigrate :: (AWSConstraint r m, MonadAWS m) => D.CreateTable -> m () -createOrMigrate tabledef = do - let tblname = tabledef ^. D.ctTableName - ers <- trying _ServiceError $ send (D.describeTable tblname) +createOrMigrate :: (MonadResource m, MonadThrow m, MonadCatch m) => Env -> D.CreateTable -> m () +createOrMigrate env tabledef = do + let tblname = tabledef ^. D.createTable_tableName + ers <- trying _ServiceError $ send env (D.newDescribeTable tblname) case ers of Left _ -> do - logmsg Info ("Creating table: " <> prettyTableInfo tabledef) - void $ send tabledef -- table doesn't exist, create a new one - waitUntilTableActive tblname True + logmsg env Info ("Creating table: " <> prettyTableInfo tabledef) + void $ send env tabledef -- table doesn't exist, create a new one + waitUntilTableActive env tblname True Right rs - | Just descr <- rs ^. D.drsTable -> do - logmsg Info ("Table " <> tblname <> " alread exists, checking schema.") - tryMigration tabledef descr + | Just descr <- rs ^. D.describeTableResponse_table -> do + logmsg env Info ("Table " <> tblname <> " alread exists, checking schema.") + tryMigration env tabledef descr | otherwise -> throwM (DynamoException "Didn't receive correct table description.") -runMigration :: (TableCreate table r, MonadAWS m, Code table ~ '[ hash ': range ': rest ]) - => Proxy table +runMigration :: (TableCreate table r, Code table ~ '[ hash ': range ': rest ], MonadResource m, MonadThrow m, MonadCatch m) + => Env + -> 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 +runMigration env ptbl globindices' locindices provisionMap stream = + 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)) + let final = tbl & bool (D.createTable_globalSecondaryIndexes ?~ map fst globindices) id (null globindices) + & bool (D.createTable_localSecondaryIndexes ?~ map fst locindices) id (null locindices) + & D.createTable_attributeDefinitions %~ (nub . (<> idxattrs)) & addStream stream - createOrMigrate final + createOrMigrate env final where getProv name = fromMaybe defaultprov (HMap.lookup name provisionMap) - defaultprov = D.provisionedThroughput 5 5 - adjustProv idx = idx & (D.gsiProvisionedThroughput .~ getProv (idx ^. D.gsiIndexName)) + defaultprov = D.newProvisionedThroughput 5 5 + adjustProv idx = idx & (D.globalSecondaryIndex_provisionedThroughput ?~ getProv (idx ^. D.globalSecondaryIndex_indexName)) addStream Nothing = id addStream (Just stype) = - let strspec = D.streamSpecification & D.ssStreamEnabled .~ Just True - & D.ssStreamViewType .~ Just stype - in D.ctStreamSpecification .~ Just strspec + let enabled = True + strspec = D.newStreamSpecification enabled & D.streamSpecification_streamViewType ?~ stype + in D.createTable_streamSpecification ?~ strspec diff --git a/src/Database/DynamoDB/QueryRequest.hs b/src/Database/DynamoDB/QueryRequest.hs index 1f0427a..68151cd 100644 --- a/src/Database/DynamoDB/QueryRequest.hs +++ b/src/Database/DynamoDB/QueryRequest.hs @@ -43,10 +43,11 @@ module Database.DynamoDB.QueryRequest ( import Control.Arrow (first, second) import Control.Lens (Lens', sequenceOf, view, (%~), - (.~), (^.), _2) + (.~), (?~), (^.), _2) import Control.Lens.TH (makeLenses) import Control.Monad ((>=>)) import Control.Monad.Catch (throwM) +import Control.Monad.Trans.Resource import Data.Bool (bool) import Data.Conduit (Conduit, Source, (=$=)) import qualified Data.Conduit.List as CL @@ -54,7 +55,7 @@ import Data.Foldable (toList) import Data.Function ((&)) import Data.HashMap.Strict (HashMap) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid ((<>)) import Data.Proxy import Data.Sequence (Seq) @@ -75,7 +76,7 @@ import Database.DynamoDB.Internal import Database.DynamoDB.Types -- | Decode data, throw exception if decoding fails. -rsDecoder :: (MonadAWS m, DynamoCollection a r t) +rsDecoder :: (DynamoCollection a r t, MonadResource m, MonadThrow m) => HashMap T.Text D.AttributeValue -> m a rsDecoder item = case dGsDecode item of @@ -89,9 +90,9 @@ data QueryOpts a hash range = QueryOpts { , _qFilterCondition :: Maybe (FilterCondition a) , _qConsistentRead :: Consistency , _qDirection :: Direction - , _qLimit :: Maybe Natural -- ^ This sets the "D.qLimit" settings for maximum number of evaluated items + , _qLimit :: Maybe Natural -- ^ This sets the "D.query_limit" 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 + -- ^ Key after which the evaluation starts. When paging, this should be set to queryResponse_lastEvaluatedKey -- of the last operation. } makeLenses ''QueryOpts @@ -103,53 +104,53 @@ queryOpts key = QueryOpts key Nothing Nothing Eventually Forward Nothing Nothing queryCmd :: forall a t hash range. CanQuery a t hash 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) + & D.query_consistentRead . consistencyL .~ (q ^. qConsistentRead) + & D.query_scanIndexForward ?~ (q ^. qDirection == Forward) + & D.query_limit .~ (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) + in (D.query_expressionAttributeNames %~ Just . (<> attnames) . fromMaybe mempty) + -- HACK; https://github.com/brendanhay/amazonka/issues/332 + . bool (D.query_expressionAttributeValues %~ Just . (<> attvals) . fromMaybe mempty) id (null attvals) + . (D.query_filterExpression ?~ expr) addStartKey Nothing = id addStartKey (Just (key, range)) = - D.qExclusiveStartKey .~ dQueryKeyToAttr (Proxy :: Proxy a) (key, range) + D.query_exclusiveStartKey ?~ dQueryKeyToAttr (Proxy :: Proxy a) (key, range) -- | Same as 'querySource', but return data in original chunks. -querySourceChunks :: forall a t m hash range. (CanQuery a t hash range, MonadAWS m) - => Proxy a -> QueryOpts a hash range -> Source m [a] -querySourceChunks _ q = paginate (queryCmd q) =$= CL.mapM (\res -> mapM rsDecoder (res ^. D.qrsItems)) +querySourceChunks :: forall a t m hash range. (CanQuery a t hash range, MonadResource m, MonadThrow m) + => Env -> Proxy a -> QueryOpts a hash range -> Source m [a] +querySourceChunks env _ q = paginate env (queryCmd q) =$= CL.mapM (\res -> mapM rsDecoder (fromMaybe mempty (res ^. D.queryResponse_items))) -- | 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. -querySource :: forall a t m hash range. (CanQuery a t hash range, MonadAWS m) - => Proxy a -> QueryOpts a hash range -> Source m a -querySource p q = querySourceChunks p q =$= CL.concat +querySource :: forall a t m hash range. (CanQuery a t hash range, MonadResource m, MonadThrow m) + => Env -> Proxy a -> QueryOpts a hash range -> Source m a +querySource env p q = querySourceChunks env p q =$= CL.concat querySourceChunksByKey :: forall a parent hash rest v1 m r. - (DynamoIndex a parent 'NoRange, Code a ~ '[ hash ': rest ], DynamoScalar v1 hash, MonadAWS m, - DynamoTable parent r) - => Proxy a -> hash -> Source m [a] -querySourceChunksByKey p key = paginate sQuery =$= CL.mapM (\res -> mapM rsDecoder (res ^. D.qrsItems)) + (DynamoIndex a parent 'NoRange, Code a ~ '[ hash ': rest ], DynamoScalar v1 hash, + DynamoTable parent r, MonadResource m, MonadThrow m) + => Env -> Proxy a -> hash -> Source m [a] +querySourceChunksByKey env p key = paginate env sQuery =$= CL.mapM (\res -> mapM rsDecoder (fromMaybe mempty (res ^. D.queryResponse_items))) where - sQuery = D.query (tableName (Proxy :: Proxy parent)) - & D.qKeyConditionExpression .~ Just "#K = :key" - & D.qExpressionAttributeNames .~ HMap.singleton "#K" (head (allFieldNames p)) - & D.qExpressionAttributeValues .~ HMap.singleton ":key" (dScalarEncode key) - & D.qIndexName .~ (Just $ indexName p) + sQuery = D.newQuery (tableName (Proxy :: Proxy parent)) + & D.query_keyConditionExpression ?~ "#K = :key" + & D.query_expressionAttributeNames ?~ HMap.singleton "#K" (head (allFieldNames p)) + & D.query_expressionAttributeValues ?~ HMap.singleton ":key" (dScalarEncode key) + & D.query_indexName ?~ indexName p -- | Conduit to query global indexes with no range key; in case anyone needed it querySourceByKey :: forall a parent hash rest v1 m r. - (DynamoIndex a parent 'NoRange, Code a ~ '[ hash ': rest ], DynamoScalar v1 hash, MonadAWS m, - DynamoTable parent r) - => Proxy a -> hash -> Source m a -querySourceByKey p q = querySourceChunksByKey p q =$= CL.concat + (DynamoIndex a parent 'NoRange, Code a ~ '[ hash ': rest ], DynamoScalar v1 hash, + DynamoTable parent r, MonadResource m, MonadThrow m) + => Env -> Proxy a -> hash -> Source m a +querySourceByKey env p q = querySourceChunksByKey env p q =$= CL.concat -- | Query an index, fetch primary key from the result and immediately read -- full items from the main table. @@ -158,81 +159,87 @@ querySourceByKey p q = querySourceChunksByKey p q =$= CL.concat -- the 'qConsistentRead' to 'Strongly', fetch from global indexes is still done -- as eventually consistent. Queries on local indexes are performed according to the settings. queryOverIndex :: forall a t m v1 v2 hash r2 range rest parent. - (CanQuery a t hash range, MonadAWS m, + (CanQuery a t hash range, Code a ~ '[ hash ': range ': rest], DynamoIndex a parent 'WithRange, ContainsTableKey a parent (PrimaryKey parent r2), DynamoTable parent r2, - DynamoScalar v1 hash, DynamoScalar v2 range) - => Proxy a -> QueryOpts a hash range -> Source m parent -queryOverIndex p q = - querySourceChunks p (q & setConsistency) + DynamoScalar v1 hash, DynamoScalar v2 range, + MonadThrow m, + MonadResource m) + => Env -> Proxy a -> QueryOpts a hash range -> Source m parent +queryOverIndex env p q = + querySourceChunks env p (q & setConsistency) =$= CL.mapFoldableM batchParent where setConsistency -- Strong consistent reads not supported on global indexes | indexIsLocal p = id | otherwise = qConsistentRead .~ Eventually - batchParent vals = getItemBatch (q ^. qConsistentRead) (map dTableKey vals) + batchParent vals = getItemBatch env (q ^. qConsistentRead) (map dTableKey vals) -- | Perform a simple, eventually consistent, query. -- -- Simple to use function to query limited amount of data from database. querySimple :: forall a t m hash range. - (CanQuery a t hash range, MonadAWS m) - => Proxy a -- ^ Proxy type of a table to query + (CanQuery a t hash range, MonadResource m, MonadThrow m) + => Env + -> Proxy a -- ^ Proxy type of a table to query -> hash -- ^ Hash key -> Maybe (RangeOper range) -- ^ Range condition -> Direction -- ^ Scan direction -> Int -- ^ Maximum number of items to fetch -> m [a] -querySimple p key range direction limit = do +querySimple env p key range direction limit = do let opts = queryOpts key & qRangeCondition .~ range & qDirection .~ direction - fst <$> query p opts limit + fst <$> query env p opts limit -- | Query with condition queryCond :: forall a t m hash range. - (CanQuery a t hash range, MonadAWS m) - => Proxy a + (CanQuery a t hash range, MonadResource m, MonadThrow m) + => Env + -> Proxy a -> hash -- ^ Hash key -> Maybe (RangeOper range) -- ^ Range condition -> FilterCondition a -> Direction -- ^ Scan direction -> Int -- ^ Maximum number of items to fetch -> m [a] -queryCond p key range cond direction limit = do +queryCond env p key range cond direction limit = do let opts = queryOpts key & qRangeCondition .~ range & qDirection .~ direction - & qFilterCondition .~ Just cond - fst <$> query p opts limit + & qFilterCondition ?~ cond + fst <$> query env p 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 m range hash. - (CanQuery a t hash range, MonadAWS m) - => Proxy a + (CanQuery a t hash range, MonadResource m, MonadThrow m) + => Env + -> Proxy a -> QueryOpts a hash range -> Int -- ^ Maximum number of items to fetch -> m ([a], Maybe (PrimaryKey a 'WithRange)) -query _ opts limit = do - -- Add qLimit to the opts if not already there - and if there is no condition +query env _ opts limit = do + -- Add query_limit 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 + boundedFetch env D.query_exclusiveStartKey (fromMaybe mempty . view D.queryResponse_items) (fromMaybe mempty . view D.queryResponse_lastEvaluatedKey) cmd limit where addQLimit - | Nothing <- opts ^. qLimit, Nothing <- opts ^. qFilterCondition = qLimit .~ Just (fromIntegral limit) + | Nothing <- opts ^. qLimit, Nothing <- opts ^. qFilterCondition = qLimit ?~ fromIntegral limit | otherwise = id -- | Generic query interface for scanning/querying boundedFetch :: forall a r t m cmd. - (MonadAWS m, HasPrimaryKey a r t, AWSRequest cmd) - => Lens' cmd (HashMap T.Text D.AttributeValue) - -> (Rs cmd -> [HashMap T.Text D.AttributeValue]) - -> (Rs cmd -> HashMap T.Text D.AttributeValue) + (HasPrimaryKey a r t, AWSRequest cmd, MonadResource m, MonadThrow m) + => Env + -> Lens' cmd (Maybe (HashMap T.Text D.AttributeValue)) + -> (AWSResponse cmd -> [HashMap T.Text D.AttributeValue]) + -> (AWSResponse cmd -> HashMap T.Text D.AttributeValue) -> cmd -> Int -- ^ Maximum number of items to fetch -> m ([a], Maybe (PrimaryKey a r)) -boundedFetch startLens rsResult rsLast startcmd limit = do +boundedFetch env startLens rsResult rsLast startcmd limit = do (result, nextcmd) <- unfoldLimit fetch startcmd limit if | length result > limit -> let final = Seq.take limit result @@ -240,14 +247,14 @@ boundedFetch startLens rsResult rsLast startcmd limit = do 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)) + return (toList result, dAttrToKey (Proxy :: Proxy a) (fromMaybe mempty (rs ^. startLens))) | otherwise -> return (toList result, Nothing) where fetch cmd = do - rs <- send cmd + rs <- send env cmd items <- Seq.fromList <$> mapM rsDecoder (rsResult rs) let lastkey = rsLast rs - newquery = bool (Just (cmd & startLens .~ lastkey)) Nothing (null lastkey) + newquery = bool (Just (cmd & startLens ?~ lastkey)) Nothing (null lastkey) return (items, newquery) -- | Run command as long as Maybe cmd is Just or the resulting sequence is smaller than limit @@ -275,36 +282,37 @@ scanOpts :: ScanOpts a r scanOpts = ScanOpts Nothing Eventually Nothing Nothing Nothing -- | Conduit source for running scan; the same as 'scanSource', but return results in chunks as they come. -scanSourceChunks :: (MonadAWS m, TableScan a r t) => Proxy a -> ScanOpts a r -> Source m [a] -scanSourceChunks _ q = paginate (scanCmd q) =$= CL.mapM (\res -> mapM rsDecoder (res ^. D.srsItems)) +scanSourceChunks :: (TableScan a r t, MonadResource m, MonadThrow m) => Env -> Proxy a -> ScanOpts a r -> Source m [a] +scanSourceChunks env _ q = paginate env (scanCmd q) =$= CL.mapM (\res -> mapM rsDecoder (fromMaybe mempty (res ^. D.scanResponse_items))) -- | Conduit source for running a scan. -scanSource :: (MonadAWS m, TableScan a r t) => Proxy a -> ScanOpts a r -> Source m a -scanSource p q = scanSourceChunks p q =$= CL.concat +scanSource :: (TableScan a r t, MonadResource m, MonadThrow m) => Env -> Proxy a -> ScanOpts a r -> Source m a +scanSource env p q = scanSourceChunks env p q =$= CL.concat -- | Function to call bounded scans. Tries to return exactly requested number of items. -- -- Use 'sStartKey' to continue the scan. -scan :: (MonadAWS m, TableScan a r t) - => Proxy a +scan :: (TableScan a r t, MonadResource m, MonadThrow m) + => Env + -> Proxy a -> ScanOpts a r -- ^ Scan settings -> Int -- ^ Required result count -> m ([a], Maybe (PrimaryKey a r)) -- ^ list of results, lastEvalutedKey or Nothing if end of data reached -scan _ opts limit = do +scan env _ opts limit = do let cmd = scanCmd (opts & addSLimit) - boundedFetch D.sExclusiveStartKey (view D.srsItems) (view D.srsLastEvaluatedKey) cmd limit + boundedFetch env D.scan_exclusiveStartKey (fromMaybe mempty . view D.scanResponse_items) (fromMaybe mempty . view D.scanResponse_lastEvaluatedKey) 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) + | Nothing <- opts ^. sLimit, Nothing <- opts ^. sFilterCondition = sLimit ?~ fromIntegral limit | otherwise = id -- | Generate a "D.Query" object. scanCmd :: forall a r t. TableScan a r t => ScanOpts a r -> D.Scan scanCmd q = defaultScan (Proxy :: Proxy a) - & D.sConsistentRead . consistencyL .~ (q ^. sConsistentRead) - & D.sLimit .~ (q ^. sLimit) + & D.scan_consistentRead . consistencyL .~ (q ^. sConsistentRead) + & D.scan_limit .~ (q ^. sLimit) & addStartKey (q ^. sStartKey) & addCondition (q ^. sFilterCondition) & addParallel (q ^. sParallel) @@ -312,52 +320,54 @@ scanCmd q = 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) + in (D.scan_expressionAttributeNames %~ Just . (<> attnames) . fromMaybe mempty) + -- HACK; https://github.com/brendanhay/amazonka/issues/332 + . bool (D.scan_expressionAttributeValues %~ Just . (<> attvals) . fromMaybe mempty) id (null attvals) + . (D.scan_filterExpression ?~ expr) -- addStartKey Nothing = id - addStartKey (Just pkey) = D.sExclusiveStartKey .~ dKeyToAttr (Proxy :: Proxy a) pkey + addStartKey (Just pkey) = D.scan_exclusiveStartKey ?~ dKeyToAttr (Proxy :: Proxy a) pkey -- addParallel Nothing = id addParallel (Just (segment,total)) = - (D.sTotalSegments .~ Just total) - . (D.sSegment .~ Just segment) + (D.scan_totalSegments ?~ total) + . (D.scan_segment ?~ segment) -- | Scan table using a given filter condition. -- -- > scanCond (colAddress "Home" <.> colCity ==. "London") 10 -scanCond :: forall a m r t. (MonadAWS m, TableScan a r t) => Proxy a -> FilterCondition a -> Int -> m [a] -scanCond _ cond limit = do - let opts = scanOpts & sFilterCondition .~ Just cond +scanCond :: forall a m r t. (TableScan a r t, MonadResource m, MonadThrow m) => Env -> Proxy a -> FilterCondition a -> Int -> m [a] +scanCond env _ cond limit = do + let opts = scanOpts & sFilterCondition ?~ cond cmd = scanCmd opts - fst <$> boundedFetch D.sExclusiveStartKey (view D.srsItems) (view D.srsLastEvaluatedKey) cmd limit + fst <$> boundedFetch env D.scan_exclusiveStartKey (fromMaybe mempty . view D.scanResponse_items) (fromMaybe mempty . view D.scanResponse_lastEvaluatedKey) cmd limit -- | Conduit to do a left join on the items being sent; supposed to be used with querySourceChunks. -- -- The 'foreign key' must have an 'Ord' to facilitate faster searching. leftJoin :: forall a b m r. - (MonadAWS m, DynamoTable a r, Ord (PrimaryKey a r), ContainsTableKey a a (PrimaryKey a r)) - => Consistency + (DynamoTable a r, Ord (PrimaryKey a r), ContainsTableKey a a (PrimaryKey a r), MonadThrow m, MonadResource m) + => Env + -> Consistency -> Proxy a -- ^ Proxy type for the right table -> (b -> Maybe (PrimaryKey a r)) -> Conduit [b] m [(b, Maybe a)] -leftJoin consistency p getkey = CL.mapM doJoin +leftJoin env consistency p getkey = CL.mapM doJoin where doJoin input = do let keys = filter (dKeyIsDefined p) $ mapMaybe getkey input - rightTbl <- getItemBatch consistency keys + rightTbl <- getItemBatch env consistency keys let resultMap = Map.fromList $ map (\res -> (dTableKey res,res)) rightTbl return $ map (second (id >=> (`Map.lookup` resultMap))) $ zip input $ map getkey input -- | The same as 'leftJoin', but discard items that do not exist in the right table. innerJoin :: forall a b m r. - (MonadAWS m, DynamoTable a r, Ord (PrimaryKey a r), ContainsTableKey a a (PrimaryKey a r)) - => Consistency + (DynamoTable a r, Ord (PrimaryKey a r), ContainsTableKey a a (PrimaryKey a r), MonadThrow m, MonadResource m) + => Env + -> Consistency -> Proxy a -- ^ Proxy type for the right table -> (b -> Maybe (PrimaryKey a r)) -> Conduit [b] m [(b, a)] -innerJoin consistency p getkey = - leftJoin consistency p getkey =$= CL.map (mapMaybe (sequenceOf _2)) +innerJoin env consistency p getkey = + leftJoin env consistency p getkey =$= CL.map (mapMaybe (sequenceOf _2)) diff --git a/src/Database/DynamoDB/TH.hs b/src/Database/DynamoDB/TH.hs index df9c5a0..0c0b8ed 100644 --- a/src/Database/DynamoDB/TH.hs +++ b/src/Database/DynamoDB/TH.hs @@ -42,8 +42,7 @@ 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 Network.AWS.DynamoDB.Types (newAttributeValue, attributeValue_m, ProvisionedThroughput, StreamViewType) import Database.DynamoDB.Class import Database.DynamoDB.Migration (runMigration) @@ -139,7 +138,7 @@ mkTableDefs migname TableConfig{..} = forM_ localIndexes $ \(idx, _) -> do idxHashName <- (fst . head) <$> getFieldNames idx translateField when (idxHashName /= tblHashName) $ - fail ("Hash key " <> show idxHashName <> " in local index " <> show idx + fail ("Hash key " Data.Monoid.<> show idxHashName <> " in local index " <> show idx <> " is not equal to table hash key " <> show tblHashName) -- Instances for indices @@ -272,8 +271,8 @@ deriveCollection table translate = -- Creates: -- -- > instance DynamoEncodable Type where --- > dEncode val = Just (attributeValue & avM .~ gdEncodeG [fieldnames] val) --- > dDecode (Just attr) = gdDecodeG [fieldnames] (attr ^. avM) +-- > dEncode val = Just (newAttributeValue & attributeValue_m .~ gdEncodeG [fieldnames] val) +-- > dDecode (Just attr) = gdDecodeG [fieldnames] (attr ^. attributeValue_m) -- > dDecode Nothing = Nothing -- > instance InCollection column_type P_Column1 'NestedPath -- > instance InCollection column_type P_Column2 'NestedPath @@ -287,9 +286,9 @@ deriveEncodable' table translate = do let fieldList = listE (map (appE (varE 'T.pack) . litE . StringL . fst) tblFieldNames) lift [d| instance DynamoEncodable $(conT table) where - dEncode val = Just (attributeValue & avM .~ gsEncodeG $(fieldList) val) + dEncode val = Just (newAttributeValue & attributeValue_m .~ gsEncodeG $(fieldList) val) dDecode = either (const Nothing) Just . dDecodeEither - dDecodeEither (Just attr) = gsDecodeG $(fieldList) (attr ^. avM) + dDecodeEither (Just attr) = gsDecodeG $(fieldList) (attr ^. attributeValue_m) dDecodeEither Nothing = Left "Missing value" |] >>= tell let constrs = mkConstrNames tblFieldNames @@ -305,7 +304,7 @@ mkMigrationFunc name table globindexes locindexes = do locMap = ListE (map locIdxTemplate locindexes) let funcname = mkName name m <- newName "m" - let signature = SigD funcname (ForallT [PlainTV m] [AppT (ConT ''MonadAWS) (VarT m)] + let signature = SigD funcname (ForallT [PlainTV m] [] (AppT (AppT ArrowT (AppT (AppT (ConT ''HashMap) (ConT ''T.Text)) (ConT ''ProvisionedThroughput))) (AppT (AppT ArrowT (AppT (ConT ''Maybe) (ConT ''StreamViewType))) diff --git a/src/Database/DynamoDB/THConvert.hs b/src/Database/DynamoDB/THConvert.hs index d7f128a..ffaa485 100644 --- a/src/Database/DynamoDB/THConvert.hs +++ b/src/Database/DynamoDB/THConvert.hs @@ -35,7 +35,7 @@ createTableConversions :: (String -> String) -> Name -> [Name] -> WriterT [Dec] createTableConversions translate table idxes = do tblFields <- getFieldNames table translate tblConstr <- lift $ getConstructor table - clsname <- lift $ newName $ "IndexToTable_" <> nameBase tblConstr + clsname <- lift $ newName $ "IndexToTable_" Data.Monoid.<> nameBase tblConstr a <- lift $ newName "a" let clsdef = ClassD [] clsname [PlainTV a] [] [SigD funcname (AppT (AppT ArrowT (VarT a)) (ConT table))] let instth = mapM_ (mkInstance tblFields tblConstr clsname) idxes diff --git a/src/Database/DynamoDB/THLens.hs b/src/Database/DynamoDB/THLens.hs index 5558a3d..7b5d962 100644 --- a/src/Database/DynamoDB/THLens.hs +++ b/src/Database/DynamoDB/THLens.hs @@ -78,7 +78,7 @@ 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 + Left err -> fail $ "Table " Data.Monoid.<> show tbl <> ": " <> err Right lst -> return $ map (over _1 translate) lst where getRecords :: Info -> Either String [(String, Type)] diff --git a/src/Database/DynamoDB/Types.hs b/src/Database/DynamoDB/Types.hs index 494d642..80d25cf 100644 --- a/src/Database/DynamoDB/Types.hs +++ b/src/Database/DynamoDB/Types.hs @@ -34,7 +34,7 @@ module Database.DynamoDB.Types ( ) where import Control.Exception (Exception) -import Control.Lens ((.~), (^.)) +import Control.Lens ((.~), (^.), (?~)) import qualified Data.Aeson as AE import Data.Bifunctor (first) import qualified Data.ByteString as BS @@ -45,7 +45,7 @@ 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.Maybe (fromMaybe, mapMaybe) import Data.Monoid ((<>)) import Data.Proxy import Data.UUID.Types (UUID) @@ -60,7 +60,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Data.Vector as V import Network.AWS.DynamoDB.Types (AttributeValue, ScalarAttributeType, - attributeValue) + newAttributeValue) import qualified Network.AWS.DynamoDB.Types as D import Text.Read (readMaybe) import Data.Int (Int16, Int32, Int64) @@ -71,28 +71,34 @@ data DynamoException = DynamoException T.Text deriving (Show) instance Exception DynamoException +data ScalarValueType + = ScalarValueType_S + | ScalarValueType_N + | ScalarValueType_B + -- | 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 +data ScalarValue (v :: ScalarValueType) where + ScS :: !T.Text -> ScalarValue 'ScalarValueType_S + ScN :: !Scientific -> ScalarValue 'ScalarValueType_N + ScB :: !BS.ByteString -> ScalarValue 'ScalarValueType_B + -class ScalarAuto (v :: D.ScalarAttributeType) where +class ScalarAuto (v :: ScalarValueType) 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 +instance ScalarAuto 'ScalarValueType_S where + dTypeV _ = D.ScalarAttributeType_S + dSetEncodeV lst = newAttributeValue & D.attributeValue_ss ?~ map (\(ScS txt) -> txt) lst + dSetDecodeV attr = Just $ map ScS $ fromMaybe mempty $ attr ^. D.attributeValue_ss +instance ScalarAuto 'ScalarValueType_N where + dTypeV _ = D.ScalarAttributeType_N + dSetEncodeV lst = newAttributeValue & D.attributeValue_ns ?~ map (\(ScN num) -> decodeUtf8 (toStrict $ AE.encode num)) lst + dSetDecodeV attr = traverse (\n -> ScN <$> AE.decodeStrict (encodeUtf8 n)) (fromMaybe mempty (attr ^. D.attributeValue_ss)) +instance ScalarAuto 'ScalarValueType_B where + dTypeV _ = D.ScalarAttributeType_B + dSetEncodeV lst = newAttributeValue & D.attributeValue_bs ?~ map (\(ScB txt) -> txt) lst + dSetDecodeV attr = Just $ map ScB $ fromMaybe mempty $ attr ^. D.attributeValue_bs dType :: forall a v. DynamoScalar v a => Proxy a -> ScalarAttributeType dType _ = dTypeV (Proxy :: Proxy v) @@ -100,9 +106,9 @@ 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 + ScS txt -> newAttributeValue & D.attributeValue_s .~ Just txt + ScN num -> newAttributeValue & D.attributeValue_n .~ Just (decodeUtf8 (toStrict $ AE.encode num)) + ScB bs -> newAttributeValue & D.attributeValue_b .~ Just bs dSetEncode :: DynamoScalar v a => Set.Set a -> AttributeValue dSetEncode vset = dSetEncodeV $ map scalarEncode $ toList vset @@ -115,37 +121,37 @@ dSetDecode attr = dSetDecodeV attr >>= traverse scalarDecode >>= pure . Set.from -- > instance DynamoScalar Network.AWS.DynamoDB.Types.S T.Text where -- > scalarEncode = ScS -- > scalarDecode (ScS txt) = Just txt -class ScalarAuto v => DynamoScalar (v :: D.ScalarAttributeType) a | a -> v where +class ScalarAuto v => DynamoScalar (v :: ScalarValueType) a | a -> v where -- | Scalars must have total encoding function scalarEncode :: a -> ScalarValue v - default scalarEncode :: (Show a, Read a, v ~ 'D.S) => a -> ScalarValue v + default scalarEncode :: (Show a, Read a, v ~ 'ScalarValueType_S) => a -> ScalarValue v scalarEncode = ScS . T.pack . show scalarDecode :: ScalarValue v -> Maybe a - default scalarDecode :: (Show a, Read a, v ~ 'D.S) => ScalarValue v -> Maybe a + default scalarDecode :: (Show a, Read a, v ~ 'ScalarValueType_S) => ScalarValue v -> Maybe a scalarDecode (ScS txt) = readMaybe (T.unpack txt) -instance DynamoScalar 'D.N Integer where +instance DynamoScalar 'ScalarValueType_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 +instance DynamoScalar 'ScalarValueType_N Int where scalarEncode = ScN . fromIntegral scalarDecode (ScN num) = toBoundedInteger num -instance DynamoScalar 'D.N Int16 where +instance DynamoScalar 'ScalarValueType_N Int16 where scalarEncode = ScN . fromIntegral scalarDecode (ScN num) = toBoundedInteger num -instance DynamoScalar 'D.N Int32 where +instance DynamoScalar 'ScalarValueType_N Int32 where scalarEncode = ScN . fromIntegral scalarDecode (ScN num) = toBoundedInteger num -instance DynamoScalar 'D.N Int64 where +instance DynamoScalar 'ScalarValueType_N Int64 where scalarEncode = ScN . fromIntegral scalarDecode (ScN num) = toBoundedInteger num -instance DynamoScalar 'D.N Word where +instance DynamoScalar 'ScalarValueType_N Word where scalarEncode = ScN . fromIntegral scalarDecode (ScN num) = toBoundedInteger num @@ -156,21 +162,21 @@ instance {-# OVERLAPPABLE #-} DynamoScalar v a => DynamoScalar v (Tagged x a) wh -- | 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 +instance DynamoScalar 'ScalarValueType_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 +instance DynamoScalar 'ScalarValueType_N Double where scalarEncode = ScN . fromFloatDigits scalarDecode (ScN num) = Just $ toRealFloat num -instance DynamoScalar 'D.S T.Text where +instance DynamoScalar 'ScalarValueType_S T.Text where scalarEncode = ScS scalarDecode (ScS txt) = Just txt -instance DynamoScalar 'D.B BS.ByteString where +instance DynamoScalar 'ScalarValueType_B BS.ByteString where scalarEncode = ScB scalarDecode (ScB bs) = Just bs @@ -179,12 +185,12 @@ 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) + dEncode val = Just $ newAttributeValue & D.attributeValue_s .~ (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 (Just attr) = attr ^. D.attributeValue_s >>= (readMaybe . T.unpack) dDecode Nothing = Nothing -- | Decode data. Return (Left err) on parsing error, gets @@ -203,77 +209,77 @@ instance DynamoEncodable Scientific where dEncode = Just . dScalarEncode dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Integer where dEncode = Just . dScalarEncode dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Int where dEncode = Just . dScalarEncode dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Word where dEncode = Just . dScalarEncode dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Int16 where dEncode = Just . dScalarEncode dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Int32 where dEncode = Just . dScalarEncode dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Int64 where dEncode = Just . dScalarEncode dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Double where - dEncode num = Just $ attributeValue & D.avN .~ (Just $ toShortest num) + dEncode num = Just $ newAttributeValue & D.attributeValue_n .~ (Just $ toShortest num) dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - maybe (Left "Missing value") Right (attr ^. D.avN) + maybe (Left "Missing value") Right (attr ^. D.attributeValue_n) >>= first T.pack . AE.eitherDecodeStrict . encodeUtf8 dDecodeEither Nothing = Left "Missing attr" instance DynamoEncodable Bool where - dEncode b = Just $ attributeValue & D.avBOOL .~ Just b + dEncode b = Just $ newAttributeValue & D.attributeValue_bool .~ Just b dDecode = either (const Nothing) Just . dDecodeEither - dDecodeEither (Just attr) = maybe (Left "Missing value") Right (attr ^. D.avBOOL) + dDecodeEither (Just attr) = maybe (Left "Missing value") Right (attr ^. D.attributeValue_bool) dDecodeEither Nothing = Left "Missing attr" 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 + | Just True <- attr ^. D.attributeValue_null = Just "" + | otherwise = attr ^. D.attributeValue_s dDecode Nothing = Just "" dIsMissing "" = True dIsMissing _ = False instance DynamoEncodable BS.ByteString where dEncode "" = Nothing dEncode bs = Just (dScalarEncode bs) - dDecode (Just attr) = attr ^. D.avB + dDecode (Just attr) = attr ^. D.attributeValue_b dDecode Nothing = Just "" dIsMissing "" = True dIsMissing _ = False @@ -282,7 +288,7 @@ instance DynamoEncodable BS.ByteString where instance DynamoEncodable UUID where dEncode uuid = dEncode (UUID.toText uuid) dDecode attr = attr >>= dDecode . Just >>= UUID.fromText -instance DynamoScalar 'D.S UUID where +instance DynamoScalar 'ScalarValueType_S UUID where scalarEncode = ScS . UUID.toText scalarDecode (ScS txt) = UUID.fromText txt @@ -305,18 +311,18 @@ instance (Ord a, DynamoScalar v a) => DynamoEncodable (Set.Set a) where 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 + in Just $ newAttributeValue & D.attributeValue_m ?~ textmap dDecode = either (const Nothing) Just . dDecodeEither dDecodeEither (Just attr) = - let attrlist = traverse (\(key, val) -> (fromText key,) <$> dDecodeEither (Just val)) $ HMap.toList (attr ^. D.avM) + let attrlist = traverse (\(key, val) -> (fromText key,) <$> dDecodeEither (Just val)) $ HMap.toList (fromMaybe mempty (attr ^. D.attributeValue_m)) in HMap.fromList <$> attrlist dDecodeEither Nothing = Right 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 + dEncode lst = Just $ newAttributeValue & D.attributeValue_l ?~ mapMaybe dEncode lst dDecode = either (const Nothing) Just . dDecodeEither - dDecodeEither (Just attr) = traverse (dDecodeEither . Just) (attr ^. D.avL) + dDecodeEither (Just attr) = traverse (dDecodeEither . Just) (fromMaybe mempty (attr ^. D.attributeValue_l)) dDecodeEither Nothing = Right mempty dIsMissing = null @@ -331,24 +337,25 @@ 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 num@(AE.Number _) = Just $ newAttributeValue & D.attributeValue_n .~ Just (decodeUtf8 (toStrict $ AE.encode num)) dEncode (AE.Bool b) = dEncode b - dEncode AE.Null = Just $ attributeValue & D.avNULL .~ Just True + dEncode AE.Null = Just $ newAttributeValue & D.attributeValue_null .~ Just True -- dDecode = either (const Nothing) Just . dDecodeEither + --dDecodeEither :: Maybe AttributeValue -> Either T.Text AE.Object --TODO: drop dDecodeEither Nothing = Right AE.Null dDecodeEither (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)] -> Right (AE.Bool val) - [("L", _)] -> (AE.Array .V.fromList) <$> mapM (dDecodeEither . Just) (attr ^. D.avL) - [("M", _)] -> AE.Object <$> mapM (dDecodeEither . Just) (attr ^. D.avM) + [("L", _)] -> (AE.Array .V.fromList) <$> mapM (dDecodeEither . Just) (fromMaybe mempty (attr ^. D.attributeValue_l)) + [("M", _)] -> AE.Object <$> mapM (dDecodeEither . Just) (fromMaybe mempty (attr ^. D.attributeValue_m)) [("N", AE.String num)] -> first T.pack (AE.eitherDecodeStrict (encodeUtf8 num)) [("N", num@(AE.Number _))] -> Right num -- Just in case, this is usually not returned [("S", AE.String val)] -> Right (AE.String val) [("NULL", _)] -> Right AE.Null - _ -> Left ("Undecodable json value: " <> decodeUtf8 (toStrict (AE.encode obj))) + _ -> Left ("Undecodable json value: " Data.Monoid.<> decodeUtf8 (toStrict (AE.encode obj))) _ -> Left "Wrong dynamo data" -- This shouldn't happen -- dIsMissing AE.Null = True diff --git a/test/BaseSpec.hs b/test/BaseSpec.hs index 8c7dcdf..e38e56a 100644 --- a/test/BaseSpec.hs +++ b/test/BaseSpec.hs @@ -13,6 +13,7 @@ import Control.Exception.Safe (SomeException, catchAny, finally, try) import Control.Lens ((.~)) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT(..)) import Data.Conduit (runConduit, (=$=)) import qualified Data.Conduit.List as CL import Data.Either (isLeft) @@ -22,7 +23,6 @@ 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 @@ -56,7 +56,7 @@ data TestSecond = TestSecond { } deriving (Show, Eq) mkTableDefs "migrateTest2" (tableConfig "" (''TestSecond, NoRange) [] []) -withDb :: Example (IO b) => String -> AWS b -> SpecWith (Arg (IO b)) +withDb :: Example (IO b) => String -> (Env -> ResourceT IO b) -> SpecWith (Arg (IO b)) withDb msg code = it msg runcode where runcode = do @@ -67,177 +67,177 @@ withDb msg code = it msg runcode 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 ()) + runResourceT $ do + deleteTable env (Proxy :: Proxy Test) `catchAny` (\_ -> return ()) migrateTest mempty Nothing migrateTest2 mempty Nothing - code `finally` deleteTable (Proxy :: Proxy Test) + code env `finally` deleteTable env (Proxy :: Proxy Test) spec :: Spec spec = do describe "Basic operations" $ do - withDb "putItem/getItem works" $ do + withDb "putItem/getItem works" $ \env -> 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 tTest ("1", 2) - it2 <- getItem Strongly tTest ("2", 3) + putItem env testitem1 + putItem env testitem2 + it1 <- getItem env Strongly tTest ("1", 2) + it2 <- getItem env Strongly tTest ("2", 3) liftIO $ Just testitem1 `shouldBe` it1 liftIO $ Just testitem2 `shouldBe` it2 - withDb "getItemBatch/putItemBatch work" $ do + withDb "getItemBatch/putItemBatch work" $ \env -> do let template i = Test (T.pack $ show i) i "text" False 3.14 i Nothing newItems = map template [1..300] - putItemBatch newItems + putItemBatch env newItems -- let keys = map tableKey newItems - items <- getItemBatch Strongly keys + items <- getItemBatch env Strongly keys liftIO $ sort items `shouldBe` sort newItems - withDb "insertItem doesn't overwrite items" $ do + withDb "insertItem doesn't overwrite items" $ \env -> 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_) + insertItem env testitem1 + (res :: Either SomeException ()) <- try (insertItem env testitem1_) liftIO $ res `shouldSatisfy` isLeft - withDb "scanSource works correctly with sLimit" $ do + withDb "scanSource works correctly with sLimit" $ \env -> do let template i = Test (T.pack $ show i) i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems + putItemBatch env newItems let squery = scanOpts & sFilterCondition .~ Just (iInt' >. 50) & sLimit .~ Just 1 - res <- runConduit $ scanSource tTest squery =$= CL.consume + res <- runConduit $ scanSource env tTest squery =$= CL.consume liftIO $ sort res `shouldBe` sort (drop 50 newItems) - withDb "querySource works correctly with qLimit" $ do + withDb "querySource works correctly with qLimit" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems + putItemBatch env newItems let squery = queryOpts "hashkey" & qFilterCondition .~ Just (iInt' >. 50) & qLimit .~ Just 1 - res <- runConduit $ querySource tTest squery =$= CL.consume + res <- runConduit $ querySource env tTest squery =$= CL.consume liftIO $ res `shouldBe` drop 50 newItems - withDb "queryCond works correctly with qLimit" $ do + withDb "queryCond works correctly with qLimit" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - items <- queryCond tTest "hashkey" Nothing (iInt' >. 50) Forward 5 + putItemBatch env newItems + items <- queryCond env tTest "hashkey" Nothing (iInt' >. 50) Forward 5 liftIO $ items `shouldBe` drop 50 newItems - withDb "scanCond works correctly" $ do + withDb "scanCond works correctly" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - items <- scanCond tTest (iInt' >. 50) 5 + putItemBatch env newItems + items <- scanCond env tTest (iInt' >. 50) 5 liftIO $ items `shouldBe` drop 50 newItems - withDb "scan works correctly with qlimit" $ do + withDb "scan works correctly with qlimit" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - (items, _) <- scan tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' >. 50)) 5 + putItemBatch env newItems + (items, _) <- scan env tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' >. 50)) 5 liftIO $ items `shouldBe` drop 50 newItems - withDb "scan works correctly with `valIn`" $ do + withDb "scan works correctly with `valIn`" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - (items, _) <- scan tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' `valIn` [20..30])) 50 + putItemBatch env newItems + (items, _) <- scan env tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' `valIn` [20..30])) 50 liftIO $ map iInt items `shouldBe` [20..30] - withDb "scan works correctly with BETWEEN" $ do + withDb "scan works correctly with BETWEEN" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - (items, _) <- scan tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' `between` (20, 30))) 50 + putItemBatch env newItems + (items, _) <- scan env tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' `between` (20, 30))) 50 liftIO $ map iInt items `shouldBe` [20..30] - withDb "scan works correctly with SIZE" $ do + withDb "scan works correctly with SIZE" $ \env -> 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 tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (size iText' >. 10)) 50 + putItem env testitem1 + putItem env testitem2 + (items, _) <- scan env tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (size iText' >. 10)) 50 liftIO $ items `shouldBe` [testitem1] - withDb "querySimple works correctly with RangeOper" $ do + withDb "querySimple works correctly with RangeOper" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - items <- querySimple tTest "hashkey" (Just $ RangeLessThan 30) Backward 5 + putItemBatch env newItems + items <- querySimple env tTest "hashkey" (Just $ RangeLessThan 30) Backward 5 liftIO $ map iRangeKey items `shouldBe` [29,28..25] - withDb "queryCond works correctly with -1 limit" $ do + withDb "queryCond works correctly with -1 limit" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - (items :: [Test]) <- queryCond tTest "hashkey" Nothing (iInt' >. 50) Backward (-1) + putItemBatch env newItems + (items :: [Test]) <- queryCond env tTest "hashkey" Nothing (iInt' >. 50) Backward (-1) liftIO $ items `shouldBe` [] - withDb "querySourceByKey works/compiles correctly" $ do + withDb "querySourceByKey works/compiles correctly" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems - res <- runConduit $ querySourceByKey iTestKeyOnly "text" =$= CL.consume + putItemBatch env newItems + res <- runConduit $ querySourceByKey env iTestKeyOnly "text" =$= CL.consume liftIO $ length res `shouldBe` 55 - withDb "updateItemByKey works" $ do + withDb "updateItemByKey works" $ \env -> do let testitem1 = Test "1" 2 "text" False 3.14 2 (Just "something") - putItem testitem1 - new1 <- updateItemByKey tTest (tableKey testitem1) - ((iInt' +=. 5) <> (iText' =. "updated") <> (iMText' =. Nothing)) - new2 <- fromJust <$> getItem Strongly tTest (tableKey testitem1) + putItem env testitem1 + new1 <- updateItemByKey env tTest (tableKey testitem1) + ((iInt' +=. 5) <> (iText' =. "updated") <> (iMText' =. Nothing)) + new2 <- fromJust <$> getItem env Strongly tTest (tableKey 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 + withDb "update fails on non-existing item" $ \env -> do let testitem1 = Test "1" 2 "text" False 3.14 2 (Just "something") - putItem testitem1 - updateItemByKey_ tTest ("1", 2) (iBool' =. True) - (res :: Either SomeException ()) <- try $ updateItemByKey_ tTest ("2", 3) (iBool' =. True) + putItem env testitem1 + updateItemByKey_ env tTest ("1", 2) (iBool' =. True) + (res :: Either SomeException ()) <- try $ updateItemByKey_ env tTest ("2", 3) (iBool' =. True) liftIO $ res `shouldSatisfy` isLeft - withDb "scan continuation works" $ do + withDb "scan continuation works" $ \env -> do let template i = Test "hashkey" i "text" False 3.14 i Nothing newItems = map template [1..55] - putItemBatch newItems + putItemBatch env newItems - (it1, next) <- scan tTest (scanOpts & sFilterCondition .~ Just (iInt' >. 20) + (it1, next) <- scan env tTest (scanOpts & sFilterCondition .~ Just (iInt' >. 20) & sLimit .~ Just 2) 5 - (it2, _) <- scan tTest (scanOpts & sFilterCondition .~ Just (iInt' >. 20) + (it2, _) <- scan env tTest (scanOpts & sFilterCondition .~ Just (iInt' >. 20) & sLimit .~ Just 1 & sStartKey .~ next) 5 liftIO $ map iInt (it1 ++ it2) `shouldBe` [21..30] - withDb "searching empty strings" $ do + withDb "searching empty strings" $ \env -> 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 <- queryCond tTest "1" Nothing (iText' ==. "") Forward 10 - items2 <- queryCond tTest "1" Nothing (iMText' ==. Nothing) Forward 10 + putItem env testitem1 + putItem env testitem2 + items1 <- queryCond env tTest "1" Nothing (iText' ==. "") Forward 10 + items2 <- queryCond env tTest "1" Nothing (iMText' ==. Nothing) Forward 10 liftIO $ items1 `shouldBe` [testitem1] liftIO $ items2 `shouldBe` [testitem1] - withDb "deleting by key" $ do + withDb "deleting by key" $ \env -> 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, _) <- scan tTest scanOpts 10 - deleteItemByKey tTest (tableKey testitem1) - deleteItemByKey tTest (tableKey testitem2) - (items2, _) <- scan tTest scanOpts 10 + putItem env testitem1 + putItem env testitem2 + (items, _) <- scan env tTest scanOpts 10 + deleteItemByKey env tTest (tableKey testitem1) + deleteItemByKey env tTest (tableKey testitem2) + (items2, _) <- scan env tTest scanOpts 10 liftIO $ do length items `shouldBe` 2 length items2 `shouldBe` 0 - withDb "test left join" $ do + withDb "test left join" $ \env -> do let testitem1 = Test "1" 2 "" False 3.14 2 Nothing let testitem2 = Test "1" 3 "aaa" False 3.14 2 (Just "aaa") let testsecond = TestSecond "aaa" 3 - putItem testitem1 - putItem testitem2 - putItem testsecond - res <- runConduit $ querySourceChunks tTest (queryOpts "1") - =$= leftJoin Strongly tTestSecond (Just . iText) + putItem env testitem1 + putItem env testitem2 + putItem env testsecond + res <- runConduit $ querySourceChunks env tTest (queryOpts "1") + =$= leftJoin env Strongly tTestSecond (Just . iText) =$= CL.concat =$= CL.consume liftIO $ res `shouldBe` [(testitem1, Nothing), (testitem2, Just testsecond)] - res2 <- runConduit $ querySourceChunks tTest (queryOpts "1") - =$= leftJoin Strongly tTestSecond iMText + res2 <- runConduit $ querySourceChunks env tTest (queryOpts "1") + =$= leftJoin env Strongly tTestSecond iMText =$= CL.concat =$= CL.consume liftIO $ res2 `shouldBe` [(testitem1, Nothing), (testitem2, Just testsecond)] From 4ec772d96a12945f95f2267ca407015a55bb1400 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Thu, 16 Sep 2021 11:21:08 -0700 Subject: [PATCH 2/4] Get tests and TH building --- src/Database/DynamoDB/TH.hs | 60 +++++++++++++++++++++++++++------- stack.yaml | 11 +++++++ stack.yaml.lock | 38 ++++++++++++++++++++++ test/BaseSpec.hs | 11 ++++--- test/NestedSpec.hs | 64 +++++++++++++++++++------------------ 5 files changed, 137 insertions(+), 47 deletions(-) create mode 100644 stack.yaml create mode 100644 stack.yaml.lock diff --git a/src/Database/DynamoDB/TH.hs b/src/Database/DynamoDB/TH.hs index 0c0b8ed..f3a77be 100644 --- a/src/Database/DynamoDB/TH.hs +++ b/src/Database/DynamoDB/TH.hs @@ -30,8 +30,10 @@ module Database.DynamoDB.TH ( import Control.Lens (ix, over, (.~), (^.), _1, view, (^..)) import Control.Monad (forM_, unless, when) +import Control.Monad.Catch (MonadCatch) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, tell) +import Control.Monad.Trans.Resource (MonadResource) import Data.Bool (bool) import Data.Char (toUpper) import Data.Function ((&)) @@ -42,6 +44,7 @@ import Generics.SOP import Generics.SOP.TH (deriveGenericOnly) import Language.Haskell.TH import Language.Haskell.TH.Syntax (Name (..), OccName (..)) +import Network.AWS (Env) import Network.AWS.DynamoDB.Types (newAttributeValue, attributeValue_m, ProvisionedThroughput, StreamViewType) import Database.DynamoDB.Class @@ -286,9 +289,9 @@ deriveEncodable' table translate = do let fieldList = listE (map (appE (varE 'T.pack) . litE . StringL . fst) tblFieldNames) lift [d| instance DynamoEncodable $(conT table) where - dEncode val = Just (newAttributeValue & attributeValue_m .~ gsEncodeG $(fieldList) val) + dEncode val = Just (newAttributeValue & attributeValue_m .~ Just (gsEncodeG $(fieldList) val)) dDecode = either (const Nothing) Just . dDecodeEither - dDecodeEither (Just attr) = gsDecodeG $(fieldList) (attr ^. attributeValue_m) + dDecodeEither (Just attr) = gsDecodeG $(fieldList) (fromMaybe mempty (attr ^. attributeValue_m)) dDecodeEither Nothing = Left "Missing value" |] >>= tell let constrs = mkConstrNames tblFieldNames @@ -304,15 +307,50 @@ mkMigrationFunc name table globindexes locindexes = do locMap = ListE (map locIdxTemplate locindexes) let funcname = mkName name m <- newName "m" - let signature = SigD funcname (ForallT [PlainTV 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)) []] + let envArg = ConT ''Env + provisionMapArg = AppT (AppT (ConT ''HashMap) (ConT ''T.Text)) (ConT ''ProvisionedThroughput) + streamArg = AppT (AppT ArrowT (AppT (ConT ''Maybe) (ConT ''StreamViewType))) (AppT (VarT m) (TupleT 0)) + -- signature = SigD funcname (ForallT [PlainTV m] [] + -- (AppT envArg (AppT ArrowT (AppT provisionMapArg (AppT ArrowT streamArg)))) + mkConstraint n = AppT (ConT n) (VarT m) + signature = SigD funcname (ForallT [PlainTV m] [mkConstraint ''MonadResource, mkConstraint ''MonadCatch] + (AppT (AppT ArrowT envArg) (AppT (AppT ArrowT provisionMapArg) streamArg)) + --TODO: drop + --(AppT ArrowT (AppT _a _b)) + -- (AppT ArrowT (AppT (''Env))) + -- ((AppT ArrowT (AppT (AppT (ConT ''HashMap) (ConT ''T.Text)) (ConT ''ProvisionedThroughput))) + -- (AppT (AppT ArrowT (AppT (ConT ''Maybe) (ConT ''StreamViewType))) (AppT (VarT m) (TupleT 0)))) + + ) + -- TODO: drop + -- return [signature, ValD (VarP funcname) (NormalB (AppE (AppE (AppE (VarE 'runMigration) + -- (SigE (ConE 'Proxy) + -- (AppT (ConT ''Proxy) + -- (ConT table)))) glMap) locMap)) []] + --TODO: update + + + + + envVarName <- newName "env" + --TODO: clean up + let tableProxy = (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT table))) + let body = NormalB + -- (AppE (VarE 'runMigration) (AppE (VarE envVarName) (AppE tableProxy (AppE glMap locMap)))) + (AppE (AppE (AppE (AppE (VarE 'runMigration) (VarE envVarName)) tableProxy) glMap) locMap) + -- (AppE + -- (AppE + -- (AppE + -- (AppE + -- (VarE 'runMigration) + -- (VarE envVarName)) + -- (SigE (ConE 'Proxy) + -- (AppT (ConT ''Proxy) + -- (ConT table)))) + -- glMap) + -- locMap) + + return [signature, FunD funcname [Clause [VarP envVarName] body []]] 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))) diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..88b8a53 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,11 @@ +resolver: lts-18.10 +packages: + - "." +extra-deps: + - git: https://github.com/brendanhay/amazonka.git + commit: 23495aaf7f08d6666f8e3bc8e72f5041ce7c6801 + subdirs: + - amazonka + - amazonka-dynamodb +flags: {} +extra-package-dbs: [] diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..b98349b --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,38 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + subdir: amazonka + name: amazonka + version: 1.6.1 + git: https://github.com/brendanhay/amazonka.git + pantry-tree: + size: 3780 + sha256: ad1d6d34a7dbc110e3e453beade324942302c383683af6745804f233243134aa + commit: 23495aaf7f08d6666f8e3bc8e72f5041ce7c6801 + original: + subdir: amazonka + git: https://github.com/brendanhay/amazonka.git + commit: 23495aaf7f08d6666f8e3bc8e72f5041ce7c6801 +- completed: + subdir: amazonka-dynamodb + name: amazonka-dynamodb + version: 1.6.1 + git: https://github.com/brendanhay/amazonka.git + pantry-tree: + size: 24750 + sha256: e2a143324fd90bfa927aae38c3364de7c814e47fd0242f8aec15ad7383406a11 + commit: 23495aaf7f08d6666f8e3bc8e72f5041ce7c6801 + original: + subdir: amazonka-dynamodb + git: https://github.com/brendanhay/amazonka.git + commit: 23495aaf7f08d6666f8e3bc8e72f5041ce7c6801 +snapshots: +- completed: + size: 587546 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/10.yaml + sha256: 88b4f81e162ba3adc230a9fcccc4d19ac116377656bab56c7382ca88598b257a + original: lts-18.10 diff --git a/test/BaseSpec.hs b/test/BaseSpec.hs index e38e56a..b52f4f7 100644 --- a/test/BaseSpec.hs +++ b/test/BaseSpec.hs @@ -23,6 +23,7 @@ import Data.Proxy import Data.Semigroup ((<>)) import qualified Data.Text as T import Network.AWS +import qualified Network.AWS.DynamoDB import System.Environment (setEnv) import System.IO (stdout) import Test.Hspec @@ -64,14 +65,14 @@ withDb msg code = it msg runcode setEnv "AWS_SECRET_ACCESS_KEY" "XXXXXXXXXXXXXXfdjdsfjdsfjdskldfs+kl" lgr <- newLogger Debug stdout env <- newEnv Discover - let dynamo = setEndpoint False "localhost" 8000 dynamoDB + let dynamo = setEndpoint False "localhost" 8000 Network.AWS.DynamoDB.defaultService let newenv = env & configure dynamo -- & set envLogger lgr runResourceT $ do - deleteTable env (Proxy :: Proxy Test) `catchAny` (\_ -> return ()) - migrateTest mempty Nothing - migrateTest2 mempty Nothing - code env `finally` deleteTable env (Proxy :: Proxy Test) + deleteTable newenv (Proxy :: Proxy Test) `catchAny` (\_ -> return ()) + migrateTest newenv mempty Nothing + migrateTest2 newenv mempty Nothing + code newenv `finally` deleteTable newenv (Proxy :: Proxy Test) spec :: Spec spec = do diff --git a/test/NestedSpec.hs b/test/NestedSpec.hs index db28d75..02d8544 100644 --- a/test/NestedSpec.hs +++ b/test/NestedSpec.hs @@ -14,17 +14,19 @@ module NestedSpec where import Control.Exception.Safe (catchAny, finally) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT) import Control.Lens (makeLenses, (^.), (^?), ix, (^..)) import Data.Function ((&)) import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap +import Data.Maybe 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 qualified Network.AWS.DynamoDB import System.Environment (setEnv) import System.IO (stdout) import Test.Hspec @@ -58,7 +60,7 @@ data Test = Test { } deriving (Show, Eq) mkTableDefs "migrateTest" (tableConfig "" (''Test, WithRange) [] []) -withDb :: Example (IO b) => String -> AWS b -> SpecWith (Arg (IO b)) +withDb :: Example (IO b) => String -> (Env -> ResourceT IO b) -> SpecWith (Arg (IO b)) withDb msg code = it msg runcode where runcode = do @@ -66,82 +68,82 @@ withDb msg code = it msg runcode setEnv "AWS_SECRET_ACCESS_KEY" "XXXXXXXXXXXXXXfdjdsfjdsfjdskldfs+kl" lgr <- newLogger Debug stdout env <- newEnv Discover - let dynamo = setEndpoint False "localhost" 8000 dynamoDB + let dynamo = setEndpoint False "localhost" 8000 Network.AWS.DynamoDB.defaultService 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) + runResourceT $ do + deleteTable newenv (Proxy :: Proxy Test) `catchAny` (\_ -> return ()) + migrateTest newenv mempty Nothing + code newenv `finally` deleteTable newenv (Proxy :: Proxy Test) spec :: Spec spec = do describe "Nested structures" $ do - withDb "Save and retrieve" $ do + withDb "Save and retrieve" $ \env -> 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 - ritem1 <- fromJust <$> getItem Strongly tTest ("hash", 1) - ritem2 <- fromJust <$> getItem Strongly tTest ("hash", 2) + putItem env testitem1 + putItem env testitem2 + ritem1 <- fromJust <$> getItem env Strongly tTest ("hash", 1) + ritem2 <- fromJust <$> getItem env Strongly tTest ("hash", 2) liftIO $ testitem1 `shouldBe` ritem1 liftIO $ testitem2 `shouldBe` ritem2 - withDb "Scan conditions" $ do + withDb "Scan conditions" $ \env -> 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 + putItem env testitem1 + putItem env testitem2 -- - items1 <- scanCond tTest (iInner' <.> nFirst' ==. "test") 10 + items1 <- scanCond env tTest (iInner' <.> nFirst' ==. "test") 10 liftIO $ items1 `shouldBe` [testitem1] -- - items2 <- scanCond tTest (iInner' <.> nFirst' ==. "") 10 + items2 <- scanCond env tTest (iInner' <.> nFirst' ==. "") 10 liftIO $ items2 `shouldBe` [testitem2] -- - items3 <- scanCond tTest (iMInner' <.> nThird' ==. "test") 10 + items3 <- scanCond env tTest (iMInner' <.> nThird' ==. "test") 10 liftIO $ items3 `shouldBe` [testitem1] -- - items4 <- scanCond tTest (iMInner' ==. Nothing) 10 + items4 <- scanCond env tTest (iMInner' ==. Nothing) 10 liftIO $ items4 `shouldBe` [testitem2] -- - items5 <- scanCond tTest (iSet' `setContains` Tagged "test") 10 + items5 <- scanCond env tTest (iSet' `setContains` Tagged "test") 10 liftIO $ items5 `shouldBe` [testitem1] -- - items6 <- scanCond tTest (iList' 0 <.> nFirst' ==. "test") 10 + items6 <- scanCond env tTest (iList' 0 <.> nFirst' ==. "test") 10 liftIO $ items6 `shouldBe` [testitem1] -- - items7 <- scanCond tTest (iMap' Tagged "test" <.> nThird' ==. "test") 10 + items7 <- scanCond env tTest (iMap' Tagged "test" <.> nThird' ==. "test") 10 liftIO $ items7 `shouldBe` [testitem1] - withDb "Nested updates" $ do + withDb "Nested updates" $ \env -> 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 + putItem env testitem1 + putItem env testitem2 -- - newitem1 <- updateItemByKey tTest (tableKey testitem1) (iInner' <.> nFirst' =. "updated") + newitem1 <- updateItemByKey env tTest (tableKey testitem1) (iInner' <.> nFirst' =. "updated") liftIO $ newitem1 ^. iInner . nFirst `shouldBe` "updated" -- - newitem2 <- updateItemByKey tTest (tableKey testitem1) (add iSet' (Set.singleton (Tagged "test2"))) + newitem2 <- updateItemByKey env tTest (tableKey testitem1) (add iSet' (Set.singleton (Tagged "test2"))) liftIO $ newitem2 ^. iSet `shouldBe` Set.fromList [Tagged "test", Tagged "test2"] -- - newitem3 <- updateItemByKey tTest (tableKey testitem1) (prepend iList' [inner2, inner1]) + newitem3 <- updateItemByKey env tTest (tableKey testitem1) (prepend iList' [inner2, inner1]) liftIO $ newitem3 ^. iList `shouldBe` [inner2, inner1, inner1] -- - newitem4 <- updateItemByKey tTest (tableKey testitem1) (delListItem iList' 1) + newitem4 <- updateItemByKey env tTest (tableKey testitem1) (delListItem iList' 1) liftIO $ newitem4 ^. iList `shouldBe` [inner2, inner1] -- - newitem5 <- updateItemByKey tTest (tableKey testitem2) (iMap' Tagged "test" =. inner1) + newitem5 <- updateItemByKey env tTest (tableKey testitem2) (iMap' Tagged "test" =. inner1) liftIO $ newitem5 ^.. iMap . traverse `shouldBe` [inner1] liftIO $ newitem5 ^? iMap . ix (Tagged "test") `shouldBe` Just inner1 -- - newitem6 <- updateItemByKey tTest (tableKey testitem2) (delHashKey iMap' (Tagged "test")) + newitem6 <- updateItemByKey env tTest (tableKey testitem2) (delHashKey iMap' (Tagged "test")) liftIO $ newitem6 ^. iMap `shouldBe` HMap.empty From 5706ea474cc3c3fbf16784fdbdc3eb5cce56ba4c Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Thu, 16 Sep 2021 11:26:48 -0700 Subject: [PATCH 3/4] Clean up commented out code --- src/Database/DynamoDB/TH.hs | 33 +-------------------------------- src/Database/DynamoDB/Types.hs | 1 - 2 files changed, 1 insertion(+), 33 deletions(-) diff --git a/src/Database/DynamoDB/TH.hs b/src/Database/DynamoDB/TH.hs index f3a77be..a6bc1ed 100644 --- a/src/Database/DynamoDB/TH.hs +++ b/src/Database/DynamoDB/TH.hs @@ -310,45 +310,14 @@ mkMigrationFunc name table globindexes locindexes = do let envArg = ConT ''Env provisionMapArg = AppT (AppT (ConT ''HashMap) (ConT ''T.Text)) (ConT ''ProvisionedThroughput) streamArg = AppT (AppT ArrowT (AppT (ConT ''Maybe) (ConT ''StreamViewType))) (AppT (VarT m) (TupleT 0)) - -- signature = SigD funcname (ForallT [PlainTV m] [] - -- (AppT envArg (AppT ArrowT (AppT provisionMapArg (AppT ArrowT streamArg)))) mkConstraint n = AppT (ConT n) (VarT m) signature = SigD funcname (ForallT [PlainTV m] [mkConstraint ''MonadResource, mkConstraint ''MonadCatch] - (AppT (AppT ArrowT envArg) (AppT (AppT ArrowT provisionMapArg) streamArg)) - --TODO: drop - --(AppT ArrowT (AppT _a _b)) - -- (AppT ArrowT (AppT (''Env))) - -- ((AppT ArrowT (AppT (AppT (ConT ''HashMap) (ConT ''T.Text)) (ConT ''ProvisionedThroughput))) - -- (AppT (AppT ArrowT (AppT (ConT ''Maybe) (ConT ''StreamViewType))) (AppT (VarT m) (TupleT 0)))) - - ) - -- TODO: drop - -- return [signature, ValD (VarP funcname) (NormalB (AppE (AppE (AppE (VarE 'runMigration) - -- (SigE (ConE 'Proxy) - -- (AppT (ConT ''Proxy) - -- (ConT table)))) glMap) locMap)) []] - --TODO: update - - - + (AppT (AppT ArrowT envArg) (AppT (AppT ArrowT provisionMapArg) streamArg))) envVarName <- newName "env" - --TODO: clean up let tableProxy = (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT table))) let body = NormalB - -- (AppE (VarE 'runMigration) (AppE (VarE envVarName) (AppE tableProxy (AppE glMap locMap)))) (AppE (AppE (AppE (AppE (VarE 'runMigration) (VarE envVarName)) tableProxy) glMap) locMap) - -- (AppE - -- (AppE - -- (AppE - -- (AppE - -- (VarE 'runMigration) - -- (VarE envVarName)) - -- (SigE (ConE 'Proxy) - -- (AppT (ConT ''Proxy) - -- (ConT table)))) - -- glMap) - -- locMap) return [signature, FunD funcname [Clause [VarP envVarName] body []]] where diff --git a/src/Database/DynamoDB/Types.hs b/src/Database/DynamoDB/Types.hs index 80d25cf..d99f055 100644 --- a/src/Database/DynamoDB/Types.hs +++ b/src/Database/DynamoDB/Types.hs @@ -343,7 +343,6 @@ instance DynamoEncodable AE.Value where -- dDecode = either (const Nothing) Just . dDecodeEither - --dDecodeEither :: Maybe AttributeValue -> Either T.Text AE.Object --TODO: drop dDecodeEither Nothing = Right AE.Null dDecodeEither (Just attr) = -- Ok, this is going to be very hacky... case AE.toJSON attr of From 16e2d97f0c1f63ea9a76b7d872fe3bd7df373a89 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Fri, 17 Sep 2021 15:40:25 -0700 Subject: [PATCH 4/4] Export ScalarValueType --- src/Database/DynamoDB/Types.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Database/DynamoDB/Types.hs b/src/Database/DynamoDB/Types.hs index d99f055..bc8041a 100644 --- a/src/Database/DynamoDB/Types.hs +++ b/src/Database/DynamoDB/Types.hs @@ -24,6 +24,7 @@ module Database.DynamoDB.Types ( -- * Marshalling , DynamoEncodable(..) , DynamoScalar(..) + , ScalarValueType (..) , ScalarValue(..) , IsText(..), IsNumber -- * Query datatype