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