diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ , subject :: T.Text , replies :: Int } deriving (Show) --- Generate instances and colCategory, colUser etc. variables for queries/updates +-- Generate instances and category', user' etc. variables for queries/updates mkTableDefs "migrate" (tableConfig (''Test, WithRange) [] []) test :: IO () @@ -30,10 +30,10 @@ -- putItem (Test "news" "john" "test" 20) -- - (item :: Maybe Test) <- getItem Eventually ("news", "john") + item <- getItem Eventually (tTest, ("news", "john")) liftIO $ print item -- - (items :: [Test]) <- scanCond (colReplies >. 15) 10 + items <- scanCond tTest (replies' >. 15) 10 liftIO $ print items ```` ### Features @@ -42,6 +42,7 @@ - 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). +- Automatically generate polymorphic lenses to access fields in main table and index records. - Standard datatypes including `Tagged` and basic default instances for data types supporting `Show/Read`. - New types can be added easily. @@ -64,7 +65,7 @@ ### 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`). +- You cannot compare attributes between themselves (i.e. `currentAccount' >=. averageAccount'`). I'm not sure this would be currently technically possible. Does anybody need it? ### Handling of NULLs @@ -79,8 +80,8 @@ * `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 +* If you use `maybeCol' == Nothing`, it gets internally replaced + by `attr_missing(maybeCol)`, 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 @@ -89,9 +90,3 @@ (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/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,7 @@ +# 0.2.0.0 + +- Changed API to always include a `Proxy` +- Added proxy generation (`tTable`, `iTableIndex`) +- Added polymorphic lenses for fields starting with underscore +- Changed generated column names from `colColumn` to `column'` +- Overriden buggy amazonka paging diff --git a/dynamodb-simple.cabal b/dynamodb-simple.cabal --- a/dynamodb-simple.cabal +++ b/dynamodb-simple.cabal @@ -1,5 +1,5 @@ name: dynamodb-simple -version: 0.1.0.0 +version: 0.2.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. @@ -12,7 +12,7 @@ bug-reports: https://github.com/ondrap/dynamodb-simple/issues category: Database build-type: Simple -extra-source-files: README.md +extra-source-files: README.md changelog.md cabal-version: >=1.10 source-repository head @@ -25,7 +25,8 @@ Database.DynamoDB.Update other-modules: Database.DynamoDB.Class, Database.DynamoDB.Migration, Database.DynamoDB.Internal, Database.DynamoDB.BatchRequest, - Database.DynamoDB.QueryRequest + Database.DynamoDB.QueryRequest, Database.DynamoDB.THLens, + Database.DynamoDB.THContains build-depends: base >=4.8 && <5, amazonka-dynamodb, generics-sop, unordered-containers, text, lens, double-conversion, semigroups, bytestring, containers, monad-supply, diff --git a/src/Database/DynamoDB.hs b/src/Database/DynamoDB.hs --- a/src/Database/DynamoDB.hs +++ b/src/Database/DynamoDB.hs @@ -20,6 +20,12 @@ -- * Introduction -- $intro + -- * Proxies + -- $proxy + + -- * Lens support + -- $lens + -- * Data types DynamoException(..) , Consistency(..) @@ -62,7 +68,7 @@ -- * Delete table , deleteTable -- * Utility functions - , itemToKey + , tableKey ) where import Control.Lens ((%~), (.~), (^.)) @@ -119,9 +125,9 @@ -- | 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 + => Consistency -> (Proxy a, PrimaryKey (Code a) r) -> m (Maybe a) +getItem consistency (p, key) = do + let cmd = dGetItem p key & D.giConsistentRead . consistencyL .~ consistency rs <- send cmd let result = rs ^. D.girsItem if | null result -> return Nothing @@ -156,7 +162,7 @@ dUpdateItem p pkey actions mcond = genAction <$> dumpActions actions where - keyfields = primaryFields (Proxy :: Proxy a) + keyfields = primaryFields p -- Create condition attribute_exists(hash_key) pkeyExists = (AttrExists . nameGenPath . pure . IntraName) (head keyfields) @@ -197,7 +203,7 @@ Just res -> return res Nothing -> throwM (DynamoException $ "Cannot decode item: " <> T.pack (show rs)) | otherwise = do - rs <- getItem Strongly pkey + rs <- getItem Strongly (p, pkey) case rs of Just res -> return res Nothing -> throwM (DynamoException "Cannot decode item.") @@ -216,9 +222,11 @@ -- | 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) +-- You can use this on both main table or on index tables if they contain the primary key from +-- the main table. Table key is always projected to indexes anyway, so just define it in +-- every index. +tableKey :: forall a parent key. ContainsTableKey a parent key => a -> (Proxy parent, key) +tableKey a = (Proxy, dTableKey a) -- $intro -- @@ -268,10 +276,45 @@ -- -- 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 +-- item <- getItem Eventually (tTest, ("news", "1-2-3-4")) +-- liftIO $ print item -- (item :: Maybe Test) -- -- Scan data using filter condition, return 10 results --- (items :: [Test]) <- scanCond (colSubject ==. "New subejct") 10 +-- items <- scanCond tTest (subject' ==. "New subejct") 10 +-- print items -- (items :: [Test]) -- @ -- -- See examples/ and test/ directories for more detail examples. + +-- $proxy +-- +-- In order to avoid ambiguity errors, most API calls need a 'Proxy' argument +-- to find out on which table or index to operate. These proxies are automatically +-- generated as a name of type prepended with "t" for tables and "i" for indexes. +-- +-- A proxy for table Test will have name tTest, for index TestIndex the name will +-- be iTestIndex. + +-- $lens +-- +-- If the field names in the table record start with an underscore, the lens +-- get automatically generated for accessing the fields. The lens are polymorphic, +-- you can use them to access the fields of both main table and all the indexes. +-- +-- @ +-- data Test = Test { +-- _messageid :: T.Text +-- , _category :: T.Text +-- , _subject :: T.Text +-- } deriving (Show) +-- data TestIndex = TestIndex { +-- _category :: T.Text +-- , _messageid :: T.Text +-- } +-- mkTableDefs "migrate" (tableConfig (''Test, WithRange) [(''TestIndex, NoRange)] []) +-- +-- doWithTest :: Test -> ... +-- doWithTest item = (item ^. category) ... +-- +-- doWithItemIdx :: TestIndex -> .. +-- getCategoryIdx item = (item ^. category) ... +-- @ diff --git a/src/Database/DynamoDB/Class.hs b/src/Database/DynamoDB/Class.hs --- a/src/Database/DynamoDB/Class.hs +++ b/src/Database/DynamoDB/Class.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif {-# 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 #-} @@ -39,6 +42,7 @@ , IndexCreate(..) , HasPrimaryKey(..) , createLocalIndex + , ContainsTableKey(..) ) where import Control.Lens ((.~), sequenceOf, _2) @@ -178,6 +182,10 @@ => IndexCreate a p 'WithRange where createGlobalIndex = defaultCreateGlobalIndexRange +class ContainsTableKey a parent key | a -> parent key where + -- | Extract table primary key from an item, if possible + dTableKey :: a -> key + -- | Return first field of a datatype gdFirstField :: forall a hash rest. (Generic a, Code a ~ '[ hash ': rest ]) => a -> hash gdFirstField item = firstField (from item) @@ -314,19 +322,17 @@ 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) => +defaultCreateGlobalIndexRange :: 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 -> 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 ], +createLocalIndex :: 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 -> (D.LocalSecondaryIndex, [D.AttributeDefinition]) createLocalIndex p = diff --git a/src/Database/DynamoDB/Filter.hs b/src/Database/DynamoDB/Filter.hs --- a/src/Database/DynamoDB/Filter.hs +++ b/src/Database/DynamoDB/Filter.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -8,7 +12,7 @@ -- -- Example as used in nested structure for scan: -- --- > scanCond (colCtvrty "a" <.> colInTreti <.> colInnPrvni ==. "x") 20 +-- > scanCond (hashitem' "a" <.> author' <.> name' ==. "x") 20 module Database.DynamoDB.Filter ( -- * Condition datatype FilterCondition(Not) diff --git a/src/Database/DynamoDB/Internal.hs b/src/Database/DynamoDB/Internal.hs --- a/src/Database/DynamoDB/Internal.hs +++ b/src/Database/DynamoDB/Internal.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -27,10 +31,12 @@ 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 +-- +-- - 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 @@ -196,7 +202,7 @@ -- | Combine attributes from nested structures. -- --- > colAddress <.> colStreet +-- > address' <.> street' (<.>) :: (InCollection col2 (UnMaybe typ) 'NestedPath) => Column typ 'TypColumn col1 -> Column typ2 'TypColumn col2 -> Column typ2 'TypColumn col1 (<.>) (Column a1) (Column a2) = Column (a1 <> a2) @@ -207,14 +213,14 @@ -- | Access an index in a nested list. -- --- > colUsers 0 <.> colName +-- > users' 0 <.> name' () :: 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 +-- > phones' "mobile" <.> number' () :: 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/QueryRequest.hs b/src/Database/DynamoDB/QueryRequest.hs --- a/src/Database/DynamoDB/QueryRequest.hs +++ b/src/Database/DynamoDB/QueryRequest.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} module Database.DynamoDB.QueryRequest ( -- * Query @@ -31,28 +34,29 @@ ) 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 Control.Arrow (first) +import Control.Lens (Lens', view, (%~), (.~), (^.)) +import Control.Lens.TH (makeLenses) +import Control.Monad.Catch (throwM) +import Data.Bool (bool) +import Data.Coerce (coerce) +import Data.Conduit (Conduit, Source, (=$=)) +import qualified Data.Conduit.List as CL +import Data.Foldable (toList) +import Data.Function ((&)) +import Data.HashMap.Strict (HashMap) +import Data.Monoid ((<>)) import Data.Proxy -import qualified Data.Text as T +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +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 qualified Network.AWS.DynamoDB.Query as D +import qualified Network.AWS.DynamoDB.Scan as D +import qualified Network.AWS.DynamoDB.Types as D +import Network.AWS.Pager (AWSPager (..)) +import Numeric.Natural (Natural) import Database.DynamoDB.Class import Database.DynamoDB.Filter @@ -113,15 +117,39 @@ addStartKey (Just (key, range)) = D.qExclusiveStartKey .~ dKeyToAttr (Proxy :: Proxy a) (key, range) +-- | When https://github.com/brendanhay/amazonka/issues/340 is fixed, remove +newtype FixedQuery = FixedQuery D.Query +instance AWSRequest FixedQuery where + type Rs FixedQuery = D.QueryResponse + request (FixedQuery a) = coerce (request a) + response lgr svc _ = response lgr svc (Proxy :: Proxy D.Query) +instance AWSPager FixedQuery where + page (FixedQuery dq) resp + | null lastkey = Nothing + | otherwise = Just $ FixedQuery (dq & D.qExclusiveStartKey .~ lastkey) + where + lastkey = resp ^. D.qrsLastEvaluatedKey + +newtype FixedScan = FixedScan D.Scan +instance AWSRequest FixedScan where + type Rs FixedScan = D.ScanResponse + request (FixedScan a) = coerce (request a) + response lgr svc _ = response lgr svc (Proxy :: Proxy D.Scan) +instance AWSPager FixedScan where + page (FixedScan dq) resp + | null lastkey = Nothing + | otherwise = Just $ FixedScan (dq & D.sExclusiveStartKey .~ lastkey) + where + lastkey = resp ^. D.srsLastEvaluatedKey + + -- | 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) + => Proxy a -> QueryOpts a hash range -> Source m a +querySource _ q = paginate (FixedQuery (queryCmd q)) =$= rsDecode (view D.qrsItems) -- | Perform a simple, eventually consistent, query. -- @@ -129,31 +157,33 @@ 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 + => Proxy a -- ^ Proxy type of a table to query + -> hash -- ^ Hash key -> Maybe (RangeOper range) -- ^ Range condition -> Direction -- ^ Scan direction -> Int -- ^ Maximum number of items to fetch -> m [a] -querySimple key range direction limit = do +querySimple p key range direction limit = do let opts = queryOpts key & qRangeCondition .~ range & qDirection .~ direction - fst <$> query opts limit + fst <$> query p 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 + => Proxy a + -> hash -- ^ Hash key -> Maybe (RangeOper range) -- ^ Range condition -> FilterCondition a -> Direction -- ^ Scan direction -> Int -- ^ Maximum number of items to fetch -> m [a] -queryCond key range cond direction limit = do +queryCond p key range cond direction limit = do let opts = queryOpts key & qRangeCondition .~ range & qDirection .~ direction & qFilterCondition .~ Just cond - fst <$> query opts limit + fst <$> query p opts limit -- | Fetch exactly the required count of items even when -- it means more calls to dynamodb. Return last evaluted key if end of data @@ -161,10 +191,11 @@ 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 + => Proxy a + -> QueryOpts a hash range -> Int -- ^ Maximum number of items to fetch -> m ([a], Maybe (PrimaryKey (Code a) 'WithRange)) -query opts limit = do +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 @@ -224,20 +255,19 @@ 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) + => Proxy a -> ScanOpts a r -> Source m a +scanSource _ q = paginate (FixedScan $ 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 + => Proxy a + -> 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 +scan _ opts limit = do let cmd = scanCmd (opts & addSLimit) boundedFetch D.sExclusiveStartKey (view D.srsItems) (view D.srsLastEvaluatedKey) cmd limit where @@ -278,10 +308,10 @@ -- | 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 + => Proxy a -> FilterCondition a -> Int -> m [a] +scanCond _ cond limit = do let opts = scanOpts & sFilterCondition .~ Just cond - runConduit $ scanSource opts =$= CL.take limit + cmd = scanCmd opts + fst <$> boundedFetch D.sExclusiveStartKey (view D.srsItems) (view D.srsLastEvaluatedKey) cmd limit diff --git a/src/Database/DynamoDB/TH.hs b/src/Database/DynamoDB/TH.hs --- a/src/Database/DynamoDB/TH.hs +++ b/src/Database/DynamoDB/TH.hs @@ -32,6 +32,7 @@ import Control.Monad (forM_, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, tell) +import Data.Bool (bool) import Data.Char (toUpper) import Data.Function ((&)) import Data.Monoid ((<>)) @@ -48,6 +49,8 @@ import Database.DynamoDB.Migration (runMigration) import Database.DynamoDB.Types import Database.DynamoDB.Internal +import Database.DynamoDB.THLens +import Database.DynamoDB.THContains -- | Configuration of TH macro for creating table instances data TableConfig = TableConfig { @@ -55,6 +58,7 @@ , 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 + , buildLens :: Bool -- ^ Builds polymorphic lens for main table and indexes for table fields starting with '_' } -- | Simple table configuration @@ -69,6 +73,7 @@ , globalIndexes = map (\(n,r) -> (n, r, nameToStr n)) globidx , localIndexes = map (\n -> (n, nameToStr n)) locidx , translateField = defaultTranslate + , buildLens = True } where nameToStr (Name (OccName name) _) = name @@ -108,8 +113,8 @@ -- > 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 +-- > first' :: Column Text TypColumn P_First +-- > first' = Column mkTableDefs :: String -- ^ Name of the migration function -> TableConfig @@ -119,11 +124,11 @@ 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 + let tblHashName = fst (head tblFieldNames) forM_ localIndexes $ \(idx, _) -> do idxHashName <- (fst . head) <$> getFieldNames idx translateField when (idxHashName /= tblHashName) $ @@ -139,17 +144,27 @@ let pkeytable = [True | _ <- [1..(pkeySize idxrange)] ] ++ repeat False forM_ (zip instfields pkeytable) $ \((fieldname, ltype), isKey) -> case lookup fieldname tblFieldNames of + -- Allow sparse index - 'Maybe a' in table, 'a' in index Just (AppT (ConT mbtype) inptype) - | mbtype == ''Maybe && inptype == ltype && isKey -> return () -- Allow sparse index - 'Maybe a' in table, 'a' in index + | mbtype == ''Maybe && inptype == ltype && isKey -> return () + -- Check if types differ Just ptype | ltype /= ptype -> fail $ "Record '" <> fieldname <> "' form index " <> show idx <> " has different type from table " <> show table <> ": " <> show ltype <> " /= " <> show ptype | otherwise -> return () + -- Unknown field, does not exist in main table Nothing -> fail ("Record '" <> fieldname <> "' from index " <> show idx <> " is not in present in table " <> show table) - + -- Create migration function migfunc <- lift $ mkMigrationFunc migname table (map (view _1) globalIndexes) (map (view _1) localIndexes) tell migfunc + -- Lenses + when buildLens $ + createPolyLenses translateField table (map (view _1) allindexes) + -- Create ContainsTableKey instances to easily extract + let pkey = map fst $ take (pkeySize tblrange) tblFieldNames + forM_ (table : map (\(a,_,_) -> a) allindexes) $ + createContainsTableKey translateField table pkey pkeySize :: RangeType -> Int pkeySize WithRange = 2 @@ -160,57 +175,48 @@ 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)) + let fieldList = 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 + let primaryList = 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 + instance DynamoCollection $(conT coll) $(conT $ mrange collrange) $(tbltype) where allFieldNames _ = $(fieldList) primaryFields _ = $(primaryList) |] >>= tell case mparent of - Nothing -> + Nothing -> do + mkCollectionProxy True lift [d| - instance DynamoTable $(pure (ConT coll)) $(pure (ConT $ mrange collrange)) where - tableName _ = $(pure $ AppE (VarE 'T.pack) (LitE (StringL tblname))) + instance DynamoTable $(conT coll) $(conT $ mrange collrange) where + tableName _ = $(appE (varE 'T.pack) (litE (StringL tblname))) |] >>= tell - Just parent -> + Just parent -> do + mkCollectionProxy False lift [d| - instance DynamoIndex $(pure (ConT coll)) $(pure (ConT parent)) $(pure (ConT $ mrange collrange)) where - indexName _ = $(pure $ AppE (VarE 'T.pack) (LitE (StringL tblname))) + instance DynamoIndex $(conT coll) $(conT parent) $(conT $ mrange collrange) where + indexName _ = $(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 + instance InCollection $(conT constr) $(conT coll) 'FullPath |] >>= tell where mrange WithRange = 'WithRange mrange NoRange = 'NoRange + mkCollectionProxy istable = do + let proxyName = mkName (bool "i" "t" istable <> nameBase coll) + say $ SigD proxyName (AppT (ConT ''Proxy) (ConT coll)) + say $ ValD (VarP proxyName) (NormalB (ConE 'Proxy)) [] --- | 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 @@ -218,29 +224,24 @@ mkConstrNames :: [(String,a)] -> [Name] mkConstrNames = map (mkName . toConstrName . fst) --- | Build P_Column0 data, add it to instances and make colColumn variable +-- | Build P_Column data, add it to instances and make column' 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) + let pat = mkName (fieldname <> "'") #if __GLASGOW_HASKELL__ >= 800 say $ DataD [] constr [] Nothing [] [] #else say $ DataD [] constr [] [] [] #endif lift [d| - instance ColumnInfo $(pure (ConT constr)) where + instance ColumnInfo $(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 = @@ -250,7 +251,7 @@ tblFieldNames <- getFieldNames table translate buildColData tblFieldNames -- Create instance DynamoEncodable - deriveEncodable table translate + deriveEncodable' table translate -- | Derive just the 'DynamoEncodable' instance -- for structures that were already derived using 'mkTableDefs' @@ -265,12 +266,15 @@ -- > 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 +deriveEncodable :: Name -> (String -> String) -> Q [Dec] +deriveEncodable name trans = execWriterT (deriveEncodable' name trans) + +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)) + let fieldList = listE (map (appE (varE 'T.pack) . litE . StringL . fst) tblFieldNames) lift [d| - instance DynamoEncodable $(pure (ConT table)) where + instance DynamoEncodable $(conT table) where dEncode val = Just (attributeValue & avM .~ gsEncodeG $(fieldList) val) dDecode (Just attr) = gsDecodeG $(fieldList) (attr ^. avM) dDecode Nothing = Nothing @@ -278,7 +282,7 @@ let constrs = mkConstrNames tblFieldNames forM_ constrs $ \constr -> lift [d| - instance InCollection $(pure (ConT constr)) $(pure (ConT table)) 'NestedPath + instance InCollection $(conT constr) $(conT table) 'NestedPath |] >>= tell -- | Creates top-leval variable as a call to a migration function with partially applied createIndex @@ -305,17 +309,22 @@ -- -- 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) +-- and smart constructors for column (tId', tBase', tDescr', etc.) and one function (migrate) -- that creates table and updates the indexes. -- --- The migration function has signature: +-- The migration function has a signature: -- -- > MonadAWS m => HashMap T.Text ProvisionedThroughput -> Maybe StreamViewType -> m0 () -- +-- ProvisionedThroughput hashmap keys are DynamoDB table or index names. +-- -- * Table by default equals name of the type. +-- * Attribute names in an index table must be the same as attribute names in the main table +-- (translateField tableFieldName == translateField indexFieldName) -- * 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 +-- * Column name is an attribute name with appended tick: tId' +-- * Predefined proxies starting with "t" for tables and "i" for indexes (e.g. 'tTest', 'iTestIndex') +-- * Polymorphic lens to access fields in both tables and indexes -- * Auxiliary datatype for column is P_ followed by capitalized attribute name ('P_TId') -- -- @ diff --git a/src/Database/DynamoDB/THContains.hs b/src/Database/DynamoDB/THContains.hs new file mode 100644 --- /dev/null +++ b/src/Database/DynamoDB/THContains.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +module Database.DynamoDB.THContains where + +import Control.Monad.Trans.Class (lift) +import Data.List (find) +import Language.Haskell.TH +import Data.Function ((&)) +import Control.Monad.Trans.Writer.Lazy (WriterT, tell) + +import Database.DynamoDB.THLens (getFieldNames, whenJust) +import Database.DynamoDB.Class (ContainsTableKey(..)) + +-- | Create ContainsTableKey instance +createContainsTableKey :: (String -> String) -> Name -> [String] -> Name -> WriterT [Dec] Q () +createContainsTableKey translate parent pkeyfields item = do + tblFieldNames <- getFieldNames item id + let pfields = pkeyfields & map (\pname -> (find (\(n,_) -> translate n == pname) tblFieldNames)) + & sequence + whenJust pfields $ \pkey -> do + case pkey of + [(fname, typ)] -> + lift [d| + instance ContainsTableKey $(conT item) $(conT parent) $(pure typ) where + dTableKey = $(varE (mkName fname)) + |] >>= tell + [(fname1, typ1), (fname2, typ2)] -> + lift [d| + instance ContainsTableKey $(conT item) $(conT parent) ($(pure typ1), $(pure typ2)) where + dTableKey a = ($(varE (mkName fname1)) a, $(varE (mkName fname2)) a) + |] >>= tell + _ -> fail "Unexpected pkey length, internal error" diff --git a/src/Database/DynamoDB/THLens.hs b/src/Database/DynamoDB/THLens.hs new file mode 100644 --- /dev/null +++ b/src/Database/DynamoDB/THLens.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Create polymorphic lens to access table & indexes +module Database.DynamoDB.THLens where + +import Control.Lens (over, _1) +import Control.Monad (forM_) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Writer.Lazy (WriterT, tell) +import Data.Function ((&)) +import Data.List (isPrefixOf) +import Data.Monoid ((<>)) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Name (..), OccName (..)) + +-- | Create lenses if the field in the primary table starts with _. +-- +-- class Test_lens_field00 a b | a -> b where +-- _field :: Functor f => (b -> f b) -> a -> f a +-- instance Test_lens_field00 Test (Maybe T.Text) where +-- field f t = (\txt -> t{_field=txt}) <$> f (_field t) +createPolyLenses :: (String -> String) -> Name -> [Name] -> WriterT [Dec] Q () +createPolyLenses translate table indexes = do + -- Get fields that can be lenses + tblfields <- getFieldNames table id + fields <- tblfields & map fst + & filter ("_" `isPrefixOf`) + & map ((,) <$> translate <*> drop 1) + & mapM mkLensClass + mapM_ createClass fields + createInstances fields table + mapM_ (createInstances fields) indexes + where + mkLensClass (field, lens) = do + clsname <- lift $ newName (nameBase table ++ "_lens_" ++ field) + return (field, (mkName lens, clsname)) + createClass (_, (lensname, clsname)) = do + a <- lift $ newName "a" + b <- lift $ newName "b" + f <- lift $ newName "f" + lift (pure $ ClassD [] clsname [PlainTV a,PlainTV b] [FunDep [a] [b]] + [SigD lensname (ForallT [PlainTV f] [AppT (ConT ''Functor) (VarT f)] + (AppT (AppT ArrowT (AppT (AppT ArrowT (VarT b)) + (AppT (VarT f) (VarT b)))) (AppT (AppT ArrowT (VarT a)) + (AppT (VarT f) (VarT a)))))]) >>= say + createInstances lensfields idx = do + tblfields <- getFieldNames idx id + forM_ tblfields $ \(fieldname, ftype) -> + whenJust (lookup (translate fieldname) lensfields) $ \(lensname, clsname) -> do + f <- lift $ newName "f" + t <- lift $ newName "t" + val <- lift $ newName "val" + let fieldSel = mkName fieldname +#if __GLASGOW_HASKELL__ >= 800 + lift (pure $ InstanceD Nothing [] (AppT (AppT (ConT clsname) (ConT idx)) ftype) + [FunD lensname [Clause [VarP f,VarP t] (NormalB (InfixE (Just (LamE [VarP val] + (RecUpdE (VarE t) [(fieldSel,VarE val)]))) (VarE 'fmap) + (Just (AppE (VarE f) (AppE (VarE fieldSel) (VarE t)))))) []]]) +#else + lift (pure $ InstanceD [] (AppT (AppT (ConT clsname) (ConT idx)) ftype) + [FunD lensname [Clause [VarP f,VarP t] (NormalB (InfixE (Just (LamE [VarP val] + (RecUpdE (VarE t) [(fieldSel,VarE val)]))) (VarE 'fmap) + (Just (AppE (VarE f) (AppE (VarE fieldSel) (VarE t)))))) []]]) +#endif + >>= say + +whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenJust (Just a) f = f a +whenJust Nothing _ = return () + +say :: Monad m => t -> WriterT [t] m () +say a = tell [a] + + +-- | 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" diff --git a/src/Database/DynamoDB/Types.hs b/src/Database/DynamoDB/Types.hs --- a/src/Database/DynamoDB/Types.hs +++ b/src/Database/DynamoDB/Types.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Database/DynamoDB/Update.hs b/src/Database/DynamoDB/Update.hs --- a/src/Database/DynamoDB/Update.hs +++ b/src/Database/DynamoDB/Update.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif + {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,7 +13,7 @@ -- Example as used in nested structure for scan: -- -- > updateItemByKey_ (Proxy :: Proxy Test, ("hashkey", "sortkey")) --- > ((colIInt +=. 5) <> (colIText =. "updated") <> (colIMText =. Nothing)) +-- > ((iInt' +=. 5) <> (iText' =. "updated") <> (iMText' =. 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. diff --git a/test/BaseSpec.hs b/test/BaseSpec.hs --- a/test/BaseSpec.hs +++ b/test/BaseSpec.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} module BaseSpec where @@ -67,8 +68,8 @@ 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) + it1 <- getItem Strongly (tTest, ("1", 2)) + it2 <- getItem Strongly (tTest, ("2", 3)) liftIO $ Just testitem1 `shouldBe` it1 liftIO $ Just testitem2 `shouldBe` it2 withDb "getItemBatch/putItemBatch work" $ do @@ -76,7 +77,7 @@ newItems = map template [1..300] putItemBatch newItems -- - let keys = map (snd . itemToKey) newItems + let keys = map (snd . tableKey) newItems items <- getItemBatch Strongly keys liftIO $ sort items `shouldBe` sort newItems withDb "insertItem doesn't overwrite items" $ do @@ -89,73 +90,73 @@ 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) + let squery = scanOpts & sFilterCondition .~ Just (iInt' >. 50) & sLimit .~ Just 1 - res <- runConduit $ scanSource squery =$= CL.consume - liftIO $ res `shouldBe` drop 50 newItems + res <- runConduit $ scanSource tTest squery =$= CL.consume + liftIO $ sort res `shouldBe` sort (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) + let squery = queryOpts "hashkey" & qFilterCondition .~ Just (iInt' >. 50) & qLimit .~ Just 1 - res <- runConduit $ querySource squery =$= CL.consume + res <- runConduit $ querySource tTest 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 + items <- queryCond tTest "hashkey" Nothing (iInt' >. 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 + items <- scanCond tTest (iInt' >. 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 + (items, _) <- scan tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' >. 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 + (items, _) <- scan tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' `valIn` [20..30])) 50 liftIO $ map iInt items `shouldBe` [20..30] withDb "scan works correctly with BETWEEN" $ do 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 + (items, _) <- scan tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (iInt' `between` (20, 30))) 50 liftIO $ map iInt items `shouldBe` [20..30] withDb "scan works correctly with SIZE" $ do 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 + (items, _) <- scan tTest (scanOpts & sLimit .~ Just 1 & sFilterCondition .~ Just (size iText' >. 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 + items <- querySimple tTest "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) + (items :: [Test]) <- queryCond tTest "hashkey" Nothing (iInt' >. 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)) + new1 <- updateItemByKey (tableKey testitem1) + ((iInt' +=. 5) <> (iText' =. "updated") <> (iMText' =. Nothing)) + Just new2 <- getItem Strongly (tableKey testitem1) liftIO $ do new1 `shouldBe` new2 iInt new1 `shouldBe` 7 @@ -165,8 +166,8 @@ 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) + updateItemByKey_ (tTest, ("1", 2)) (iBool' =. True) + (res :: Either SomeException ()) <- try $ updateItemByKey_ (tTest, ("2", 3)) (iBool' =. True) liftIO $ res `shouldSatisfy` isLeft withDb "scan continuation works" $ do @@ -174,11 +175,11 @@ 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 + (it1, next) <- scan tTest (scanOpts & sFilterCondition .~ Just (iInt' >. 20) + & sLimit .~ Just 2) 5 + (it2, _) <- scan tTest (scanOpts & sFilterCondition .~ Just (iInt' >. 20) + & sLimit .~ Just 1 + & sStartKey .~ next) 5 liftIO $ map iInt (it1 ++ it2) `shouldBe` [21..30] withDb "searching empty strings" $ do @@ -186,8 +187,8 @@ 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 + items1 <- queryCond tTest "1" Nothing (iText' ==. "") Forward 10 + items2 <- queryCond tTest "1" Nothing (iMText' ==. Nothing) Forward 10 liftIO $ items1 `shouldBe` [testitem1] liftIO $ items2 `shouldBe` [testitem1] @@ -196,10 +197,10 @@ 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 + (items, _) <- scan tTest scanOpts 10 + deleteItemByKey (tableKey testitem1) + deleteItemByKey (tableKey testitem2) + (items2, _) <- scan tTest scanOpts 10 liftIO $ do length items `shouldBe` 2 length items2 `shouldBe` 0 diff --git a/test/NestedSpec.hs b/test/NestedSpec.hs --- a/test/NestedSpec.hs +++ b/test/NestedSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -55,7 +56,6 @@ , _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 @@ -83,8 +83,8 @@ 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) + Just ritem1 <- getItem Strongly (tTest, ("hash", 1)) + Just ritem2 <- getItem Strongly (tTest, ("hash", 2)) liftIO $ testitem1 `shouldBe` ritem1 liftIO $ testitem2 `shouldBe` ritem2 withDb "Scan conditions" $ do @@ -95,25 +95,25 @@ putItem testitem1 putItem testitem2 -- - items1 <- scanCond (colIInner <.> colNFirst ==. "test") 10 + items1 <- scanCond tTest (iInner' <.> nFirst' ==. "test") 10 liftIO $ items1 `shouldBe` [testitem1] -- - items2 <- scanCond (colIInner <.> colNFirst ==. "") 10 + items2 <- scanCond tTest (iInner' <.> nFirst' ==. "") 10 liftIO $ items2 `shouldBe` [testitem2] -- - items3 <- scanCond (colIMInner <.> colNThird ==. "test") 10 + items3 <- scanCond tTest (iMInner' <.> nThird' ==. "test") 10 liftIO $ items3 `shouldBe` [testitem1] -- - items4 <- scanCond (colIMInner ==. Nothing) 10 + items4 <- scanCond tTest (iMInner' ==. Nothing) 10 liftIO $ items4 `shouldBe` [testitem2] -- - items5 <- scanCond (colISet `setContains` Tagged "test") 10 + items5 <- scanCond tTest (iSet' `setContains` Tagged "test") 10 liftIO $ items5 `shouldBe` [testitem1] -- - items6 <- scanCond (colIList 0 <.> colNFirst ==. "test") 10 + items6 <- scanCond tTest (iList' 0 <.> nFirst' ==. "test") 10 liftIO $ items6 `shouldBe` [testitem1] -- - items7 <- scanCond (colIMap Tagged "test" <.> colNThird ==. "test") 10 + items7 <- scanCond tTest (iMap' Tagged "test" <.> nThird' ==. "test") 10 liftIO $ items7 `shouldBe` [testitem1] withDb "Nested updates" $ do @@ -124,23 +124,23 @@ putItem testitem1 putItem testitem2 -- - newitem1 <- updateItemByKey (itemToKey testitem1) (colIInner <.> colNFirst =. "updated") + newitem1 <- updateItemByKey (tableKey testitem1) (iInner' <.> nFirst' =. "updated") liftIO $ newitem1 ^. iInner . nFirst `shouldBe` "updated" -- - newitem2 <- updateItemByKey (itemToKey testitem1) (add colISet (Set.singleton (Tagged "test2"))) + newitem2 <- updateItemByKey (tableKey testitem1) (add iSet' (Set.singleton (Tagged "test2"))) liftIO $ newitem2 ^. iSet `shouldBe` Set.fromList [Tagged "test", Tagged "test2"] -- - newitem3 <- updateItemByKey (itemToKey testitem1) (prepend colIList [inner2, inner1]) + newitem3 <- updateItemByKey (tableKey testitem1) (prepend iList' [inner2, inner1]) liftIO $ newitem3 ^. iList `shouldBe` [inner2, inner1, inner1] -- - newitem4 <- updateItemByKey (itemToKey testitem1) (delListItem colIList 1) + newitem4 <- updateItemByKey (tableKey testitem1) (delListItem iList' 1) liftIO $ newitem4 ^. iList `shouldBe` [inner2, inner1] -- - newitem5 <- updateItemByKey (itemToKey testitem2) (colIMap Tagged "test" =. inner1) + newitem5 <- updateItemByKey (tableKey testitem2) (iMap' 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")) + newitem6 <- updateItemByKey (tableKey testitem2) (delHashKey iMap' (Tagged "test")) liftIO $ newitem6 ^. iMap `shouldBe` HMap.empty