packages feed

aws 0.9.5 → 0.10

raw patch · 24 files changed

+3519/−531 lines, 24 filesdep +QuickCheckdep +attoparsecdep +errorsdep ~aesondep ~basedep ~bytestringnew-component:exe:DynamoDb

Dependencies added: QuickCheck, attoparsec, errors, exceptions, quickcheck-instances, safe, scientific, tagged, tasty, tasty-quickcheck

Dependency ranges changed: aeson, base, bytestring, conduit, data-default, http-conduit, http-types, mtl, text, transformers

Files

Aws/Core.hs view
@@ -134,13 +134,16 @@ import qualified Text.XML                 as XML import qualified Text.XML.Cursor          as Cu import           Text.XML.Cursor          hiding (force, forceM)+------------------------------------------------------------------------------- + -- | Types that can be logged (textually). class Loggable a where     toLogText :: a -> T.Text --- | A response with metadata. Can also contain an error response, or an internal error, via 'Attempt'.---+-- | A response with metadata. Can also contain an error response, or+-- an internal error, via 'Attempt'.+--  -- Response forms a Writer-like monad. data Response m a = Response { responseMetadata :: m                              , responseResult :: Either E.SomeException a }@@ -191,10 +194,12 @@ -- -- Note that for debugging, there is an instance for 'L.ByteString'. class Monoid (ResponseMetadata resp) => ResponseConsumer req resp where-    -- | Metadata associated with a response. Typically there is one metadata type for each AWS service.+    -- | Metadata associated with a response. Typically there is one+    -- metadata type for each AWS service.     type ResponseMetadata resp -    -- | Response parser. Takes the corresponding request, an 'IORef' for metadata, and HTTP response data.+    -- | Response parser. Takes the corresponding request, an 'IORef'+    -- for metadata, and HTTP response data.     responseConsumer :: req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp  -- | Does not parse response. For debugging.@@ -215,12 +220,14 @@ class ListResponse resp item | resp -> item where     listResponse :: resp -> [item] + -- | Associates a request type and a response type in a bi-directional way.------ This allows the type-checker to infer the response type when given the request type and vice versa.------ Note that the actual request generation and response parsing resides in 'SignQuery' and 'ResponseConsumer'--- respectively.+-- +-- This allows the type-checker to infer the response type when given+-- the request type and vice versa.+-- +-- Note that the actual request generation and response parsing+-- resides in 'SignQuery' and 'ResponseConsumer' respectively. class (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a))       => Transaction r a       | r -> a, a -> r@@ -370,7 +377,7 @@ data Protocol     = HTTP     | HTTPS-    deriving (Show)+    deriving (Eq,Read,Show,Ord,Typeable)  -- | The default port to be used for a protocol if no specific port is specified. defaultPort :: Protocol -> Int@@ -458,18 +465,28 @@                                         , fmap (\auth -> ("Authorization", auth)) mauth]                               ++ sqAmzHeaders                               ++ sqOtherHeaders-      , HTTP.requestBody = case sqMethod of-                             PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery-                             _         -> case sqBody of-                                            Nothing -> HTTP.RequestBodyBuilder 0 mempty-                                            Just x  -> x+      , HTTP.requestBody = ++        -- An explicityly defined body parameter should overwrite everything else.+        case sqBody of+          Just x -> x+          Nothing -> +            -- a POST query should convert its query string into the body+            case sqMethod of+              PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $ +                           HTTP.renderQueryBuilder False sqQuery+              _         -> HTTP.RequestBodyBuilder 0 mempty+       , HTTP.decompress = HTTP.alwaysDecompress       , HTTP.checkStatus = \_ _ _ -> Nothing       }-    where contentType = case sqMethod of-                           PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"-                           _ -> sqContentType-          checkDate f mb = maybe (f <$> mb) (const Nothing) $ lookup "date" sqOtherHeaders+    where +      checkDate f mb = maybe (f <$> mb) (const Nothing) $ lookup "date" sqOtherHeaders+      -- An explicitly defined content-type should override everything else.+      contentType = sqContentType `mplus` defContentType+      defContentType = case sqMethod of+                         PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"+                         _ -> Nothing  -- | Create a URI fro a 'SignedQuery' object. --@@ -651,9 +668,10 @@     debugServiceConfig :: config     debugServiceConfig = defServiceConfig --- | @queryList f prefix xs@ constructs a query list from a list of elements @xs@, using a common prefix @prefix@,--- and a transformer function @f@.---+-- | @queryList f prefix xs@ constructs a query list from a list of+-- elements @xs@, using a common prefix @prefix@, and a transformer+-- function @f@.+--  -- A dot (@.@) is interspersed between prefix and generated key. -- -- Example:@@ -751,7 +769,7 @@ instance E.Exception FormException  -- | No credentials were found and an invariant was violated.-newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMesage :: String }+newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMessage :: String }     deriving (Show, Typeable)  instance E.Exception NoCredentialsException
+ Aws/DynamoDb.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynaboDb+-- Copyright   :  Ozgun Ataman, Soostone Inc.+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman <oz@soostone.com>+-- Stability   :  experimental+--+----------------------------------------------------------------------------++module Aws.DynamoDb+    ( module Aws.DynamoDb.Core+    , module Aws.DynamoDb.Commands+    ) where++-------------------------------------------------------------------------------+import           Aws.DynamoDb.Commands+import           Aws.DynamoDb.Core+-------------------------------------------------------------------------------
Aws/DynamoDb/Commands.hs view
@@ -1,5 +1,17 @@-module Aws.DynamoDb.Commands(-    module Aws.DynamoDb.Commands.Table-) where+module Aws.DynamoDb.Commands+    ( module Aws.DynamoDb.Commands.GetItem+    , module Aws.DynamoDb.Commands.PutItem+    , module Aws.DynamoDb.Commands.Query+    , module Aws.DynamoDb.Commands.Scan+    , module Aws.DynamoDb.Commands.Table+    , module Aws.DynamoDb.Commands.UpdateItem+    ) where -import Aws.DynamoDb.Commands.Table+-------------------------------------------------------------------------------+import           Aws.DynamoDb.Commands.GetItem+import           Aws.DynamoDb.Commands.PutItem+import           Aws.DynamoDb.Commands.Query+import           Aws.DynamoDb.Commands.Scan+import           Aws.DynamoDb.Commands.Table+import           Aws.DynamoDb.Commands.UpdateItem+-------------------------------------------------------------------------------
+ Aws/DynamoDb/Commands/GetItem.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies    #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.GetItem+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability   :  experimental+--+--+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.GetItem where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import qualified Data.Text           as T+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-- | A GetItem query that fetches a specific object from DDB.+--+-- See: @http://docs.aws.amazon.com/amazondynamodb/latest/developerguide/API_GetItem.html@+data GetItem = GetItem {+      giTableName  :: T.Text+    , giKey        :: PrimaryKey+    , giAttrs      :: Maybe [T.Text]+    -- ^ Attributes to get. 'Nothing' grabs everything.+    , giConsistent :: Bool+    -- ^ Whether to issue a consistent read.+    , giRetCons    :: ReturnConsumption+    -- ^ Whether to return consumption stats.+    } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'GetItem' request.+getItem+    :: T.Text                   -- ^ Table name+    -> PrimaryKey               -- ^ Primary key+    -> GetItem+getItem tn k = GetItem tn k Nothing False def+++-- | Response to a 'GetItem' query.+data GetItemResponse = GetItemResponse {+      girItem     :: Maybe Item+    , girConsumed :: Maybe ConsumedCapacity+    } deriving (Eq,Show,Read,Ord)+++instance Transaction GetItem GetItemResponse+++instance ToJSON GetItem where+    toJSON GetItem{..} = object $+        maybe [] (return . ("AttributesToGet" .=)) giAttrs +++        [ "TableName" .= giTableName+        , "Key" .= giKey+        , "ConsistentRead" .= giConsistent+        , "ReturnConsumedCapacity" .= giRetCons+        ]+++instance SignQuery GetItem where+    type ServiceConfiguration GetItem = DdbConfiguration+    signQuery gi = ddbSignQuery "GetItem" gi++++instance FromJSON GetItemResponse where+    parseJSON (Object v) = GetItemResponse+        <$> v .:? "Item"+        <*> v .:? "ConsumedCapacity"+    parseJSON _ = fail "GetItemResponse must be an object."+++instance ResponseConsumer r GetItemResponse where+    type ResponseMetadata GetItemResponse = DdbResponse+    responseConsumer _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse GetItemResponse where+    type MemoryResponse GetItemResponse = GetItemResponse+    loadToMemory = return
+ Aws/DynamoDb/Commands/PutItem.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.GetItem+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability   :  experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_PutItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.PutItem where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import qualified Data.Text           as T+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++data PutItem = PutItem {+      piTable   :: T.Text+    -- ^ Target table+    , piItem    :: Item+    -- ^ An item to Put. Attributes here will replace what maybe under+    -- the key on DDB.+    , piExpect  :: Conditions+    -- ^ (Possible) set of expections for a conditional Put+    , piReturn  :: UpdateReturn+    -- ^ What to return from this query.+    , piRetCons :: ReturnConsumption+    , piRetMet  :: ReturnItemCollectionMetrics+    } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'PutItem' request.+putItem :: T.Text+        -- ^ A Dynamo table name+        -> Item+        -- ^ Item to be saved+        -> PutItem+putItem tn it = PutItem tn it def def def def+++instance ToJSON PutItem where+    toJSON PutItem{..} =+        object $ expectsJson piExpect +++          [ "TableName" .= piTable+          , "Item" .= piItem+          , "ReturnValues" .= piReturn+          , "ReturnConsumedCapacity" .= piRetCons+          , "ReturnItemCollectionMetrics" .= piRetMet+          ]++++data PutItemResponse = PutItemResponse {+      pirAttrs    :: Maybe Item+    -- ^ Old attributes, if requested+    , pirConsumed :: Maybe ConsumedCapacity+    -- ^ Amount of capacity consumed+    , pirColMet   :: Maybe ItemCollectionMetrics+    -- ^ Collection metrics if they have been requested.+    } deriving (Eq,Show,Read,Ord)++++instance Transaction PutItem PutItemResponse+++instance SignQuery PutItem where+    type ServiceConfiguration PutItem = DdbConfiguration+    signQuery gi = ddbSignQuery "PutItem" gi+++instance FromJSON PutItemResponse where+    parseJSON (Object v) = PutItemResponse+        <$> v .:? "Attributes"+        <*> v .:? "ConsumedCapacity"+        <*> v .:? "ItemCollectionMetrics"+    parseJSON _ = fail "PutItemResponse must be an object."+++instance ResponseConsumer r PutItemResponse where+    type ResponseMetadata PutItemResponse = DdbResponse+    responseConsumer _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse PutItemResponse where+    type MemoryResponse PutItemResponse = PutItemResponse+    loadToMemory = return++++++++
+ Aws/DynamoDb/Commands/Query.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies    #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.Query+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability   :  experimental+--+-- Implementation of Amazon DynamoDb Query command.+--+-- See: @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_Query.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.Query+    ( Query (..)+    , Slice (..)+    , query+    , QueryResponse (..)+    ) where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import           Data.Maybe+import qualified Data.Text           as T+import           Data.Typeable+import qualified Data.Vector         as V+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | 'Slice' is the primary constraint in a 'Query' command, per AWS+-- requirements.+--+-- All 'Query' commands must specify a hash attribute via 'DEq' and+-- optionally provide a secondary range attribute.+data Slice = Slice {+      sliceHash :: Attribute+    -- ^ Hash value of the primary key or index being used+    , sliceCond :: Maybe Condition+    -- ^ An optional condition specified on the range component, if+    -- present, of the primary key or index being used.+    }  deriving (Eq,Show,Read,Ord,Typeable)++++-- | A Query command that uses primary keys for an expedient scan.+data Query = Query {+      qTableName     :: T.Text+    -- ^ Required.+    , qKeyConditions :: Slice+    -- ^ Required. Hash or hash-range main condition.+    , qFilter        :: Conditions+    -- ^ Whether to filter results before returning to client+    , qStartKey      :: Maybe [Attribute]+    -- ^ Exclusive start key to resume a previous query.+    , qLimit         :: Maybe Int+    -- ^ Whether to limit result set size+    , qForwardScan   :: Bool+    -- ^ Set to False for descending results+    , qSelect        :: QuerySelect+    -- ^ What to return from 'Query'+    , qRetCons       :: ReturnConsumption+    , qIndex         :: Maybe T.Text+    -- ^ Whether to use a secondary/global index+    , qConsistent    :: Bool+    } deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+instance ToJSON Query where+    toJSON Query{..} = object $+      catMaybes+        [ (("ExclusiveStartKey" .= ) . attributesJson) <$> qStartKey+        , ("Limit" .= ) <$> qLimit+        , ("IndexName" .= ) <$> qIndex+        ] +++      conditionsJson "QueryFilter" qFilter +++      querySelectJson qSelect +++      [ "ScanIndexForward" .= qForwardScan+      , "TableName".= qTableName+      , "KeyConditions" .= sliceJson qKeyConditions+      , "ReturnConsumedCapacity" .= qRetCons+      , "ConsistentRead" .= qConsistent+      ]+++-------------------------------------------------------------------------------+-- | Construct a minimal 'Query' request.+query+    :: T.Text+    -- ^ Table name+    -> Slice+    -- ^ Primary key slice for query+    -> Query+query tn sl = Query tn sl def Nothing Nothing True def def Nothing False+++-- | Response to a 'Query' query.+data QueryResponse = QueryResponse {+      qrItems    :: V.Vector Item+    , qrLastKey  :: Maybe [Attribute]+    , qrCount    :: Int+    , qrScanned  :: Int+    , qrConsumed :: Maybe ConsumedCapacity+    } deriving (Eq,Show,Read,Ord)+++instance FromJSON QueryResponse where+    parseJSON (Object v) = QueryResponse+        <$> v .:?  "Items" .!= V.empty+        <*> ((do o <- v .: "LastEvaluatedKey"+                 Just <$> parseAttributeJson o)+             <|> pure Nothing)+        <*> v .:  "Count"+        <*> v .:  "ScannedCount"+        <*> v .:? "ConsumedCapacity"+    parseJSON _ = fail "QueryResponse must be an object."+++instance Transaction Query QueryResponse+++instance SignQuery Query where+    type ServiceConfiguration Query = DdbConfiguration+    signQuery gi = ddbSignQuery "Query" gi+++instance ResponseConsumer r QueryResponse where+    type ResponseMetadata QueryResponse = DdbResponse+    responseConsumer _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse QueryResponse where+    type MemoryResponse QueryResponse = QueryResponse+    loadToMemory = return+++instance ListResponse QueryResponse Item where+    listResponse = V.toList . qrItems+++instance IteratedTransaction Query QueryResponse where+    nextIteratedRequest request response = case qrLastKey response of+        Nothing -> Nothing+        key -> Just request { qStartKey = key }+++sliceJson :: Slice -> Value+sliceJson Slice{..} = object (map conditionJson cs)+    where+      cs = maybe [] return sliceCond ++ [hashCond]+      hashCond = Condition (attrName sliceHash) (DEq (attrVal sliceHash))
+ Aws/DynamoDb/Commands/Scan.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies    #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.Scan+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability   :  experimental+--+-- Implementation of Amazon DynamoDb Scan command.+--+-- See: @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_Scan.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.Scan+    ( Scan (..)+    , scan+    , ScanResponse (..)+    ) where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import           Data.Maybe+import qualified Data.Text           as T+import           Data.Typeable+import qualified Data.Vector         as V+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-- | A Scan command that uses primary keys for an expedient scan.+data Scan = Scan {+      sTableName     :: T.Text+    -- ^ Required.+    , sFilter        :: Conditions+    -- ^ Whether to filter results before returning to client+    , sStartKey      :: Maybe [Attribute]+    -- ^ Exclusive start key to resume a previous query.+    , sLimit         :: Maybe Int+    -- ^ Whether to limit result set size+    , sSelect        :: QuerySelect+    -- ^ What to return from 'Scan'+    , sRetCons       :: ReturnConsumption+    , sSegment       :: Int+    -- ^ Segment number, starting at 0, for parallel queries.+    , sTotalSegments :: Int+    -- ^ Total number of parallel segments. 1 means sequential scan.+    } deriving (Eq,Show,Read,Ord,Typeable)+++-- | Construct a minimal 'Scan' request.+scan :: T.Text                   -- ^ Table name+     -> Scan+scan tn = Scan tn def Nothing Nothing def def 0 1+++-- | Response to a 'Scan' query.+data ScanResponse = ScanResponse {+      srItems    :: V.Vector Item+    , srLastKey  :: Maybe [Attribute]+    , srCount    :: Int+    , srScanned  :: Int+    , srConsumed :: Maybe ConsumedCapacity+    } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+instance ToJSON Scan where+    toJSON Scan{..} = object $+      catMaybes+        [ (("ExclusiveStartKey" .= ) . attributesJson) <$> sStartKey+        , ("Limit" .= ) <$> sLimit+        ] +++      conditionsJson "ScanFilter" sFilter +++      querySelectJson sSelect +++      [ "TableName".= sTableName+      , "ReturnConsumedCapacity" .= sRetCons+      , "Segment" .= sSegment+      , "TotalSegments" .= sTotalSegments+      ]+++instance FromJSON ScanResponse where+    parseJSON (Object v) = ScanResponse+        <$> v .:?  "Items" .!= V.empty+        <*> ((do o <- v .: "LastEvaluatedKey"+                 Just <$> parseAttributeJson o)+             <|> pure Nothing)+        <*> v .:  "Count"+        <*> v .:  "ScannedCount"+        <*> v .:? "ConsumedCapacity"+    parseJSON _ = fail "ScanResponse must be an object."+++instance Transaction Scan ScanResponse+++instance SignQuery Scan where+    type ServiceConfiguration Scan = DdbConfiguration+    signQuery gi = ddbSignQuery "Scan" gi+++instance ResponseConsumer r ScanResponse where+    type ResponseMetadata ScanResponse = DdbResponse+    responseConsumer _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse ScanResponse where+    type MemoryResponse ScanResponse = ScanResponse+    loadToMemory = return++instance ListResponse ScanResponse Item where+    listResponse = V.toList . srItems++instance IteratedTransaction Scan ScanResponse where+    nextIteratedRequest request response =+        case srLastKey response of+            Nothing -> Nothing+            key -> Just request { sStartKey = key }
Aws/DynamoDb/Commands/Table.hs view
@@ -1,104 +1,121 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}-module Aws.DynamoDb.Commands.Table(-  -- * Commands-    CreateTable(..)-  , CreateTableResult(..)-  , DescribeTable(..)-  , DescribeTableResult(..)-  , UpdateTable(..)-  , UpdateTableResult(..)-  , DeleteTable(..)-  , DeleteTableResult(..)-  , ListTables(..)-  , ListTablesResult(..)+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-} -  -- * Data passed in the commands-  , KeyAttributeType(..)-  , KeyAttributeDefinition(..)-  , KeySchema(..)-  , Projection(..)-  , LocalSecondaryIndex(..)-  , LocalSecondaryIndexStatus(..)-  , ProvisionedThroughput(..)-  , ProvisionedThroughputStatus(..)-  , GlobalSecondaryIndex(..)-  , GlobalSecondaryIndexStatus(..)-  , GlobalSecondaryIndexUpdate(..)-  , TableDescription(..)-) where+module Aws.DynamoDb.Commands.Table+    ( -- * Commands+      CreateTable(..)+    , createTable+    , CreateTableResult(..)+    , DescribeTable(..)+    , DescribeTableResult(..)+    , UpdateTable(..)+    , UpdateTableResult(..)+    , DeleteTable(..)+    , DeleteTableResult(..)+    , ListTables(..)+    , ListTablesResult(..) -import           Aws.Core-import           Aws.DynamoDb.Core+    -- * Data passed in the commands+    , AttributeType(..)+    , AttributeDefinition(..)+    , KeySchema(..)+    , Projection(..)+    , LocalSecondaryIndex(..)+    , LocalSecondaryIndexStatus(..)+    , ProvisionedThroughput(..)+    , ProvisionedThroughputStatus(..)+    , GlobalSecondaryIndex(..)+    , GlobalSecondaryIndexStatus(..)+    , GlobalSecondaryIndexUpdate(..)+    , TableDescription(..)+    ) where++------------------------------------------------------------------------------- import           Control.Applicative-import           Data.Aeson ((.=), (.:), (.!=), (.:?))-import qualified Data.Aeson as A-import qualified Data.Aeson.Types as A-import           Data.Char (toUpper)+import           Data.Aeson            ((.!=), (.:), (.:?), (.=))+import qualified Data.Aeson            as A+import qualified Data.Aeson.Types      as A+import           Data.Char             (toUpper)+import qualified Data.HashMap.Strict   as M+import qualified Data.Text             as T import           Data.Time import           Data.Time.Clock.POSIX-import qualified Data.Text             as T+import           Data.Typeable import qualified Data.Vector           as V-import qualified Data.HashMap.Strict   as M-import           GHC.Generics (Generic)+import           GHC.Generics          (Generic)+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+------------------------------------------------------------------------------- + capitalizeOpt :: A.Options-capitalizeOpt = A.defaultOptions { A.fieldLabelModifier = \x -> case x of-                                                                  (c:cs) -> toUpper c : cs-                                                                  [] -> []-                                 }+capitalizeOpt = A.defaultOptions+    { A.fieldLabelModifier = \x -> case x of+                                     (c:cs) -> toUpper c : cs+                                     [] -> []+    }   dropOpt :: Int -> A.Options dropOpt d = A.defaultOptions { A.fieldLabelModifier = drop d }  --- | The type of a key attribute that appears in the table key or as a key in one of the indices.-data KeyAttributeType = AttrStringT | AttrNumberT | AttrBinaryT-    deriving (Show, Eq, Enum, Bounded, Generic)-instance A.ToJSON KeyAttributeType where-    toJSON AttrStringT = A.String "S"-    toJSON AttrNumberT = A.String "N"-    toJSON AttrBinaryT = A.String "B"-instance A.FromJSON KeyAttributeType where+-- | The type of a key attribute that appears in the table key or as a+-- key in one of the indices.+data AttributeType = AttrString | AttrNumber | AttrBinary+    deriving (Show, Read, Ord, Typeable, Eq, Enum, Bounded, Generic)++instance A.ToJSON AttributeType where+    toJSON AttrString = A.String "S"+    toJSON AttrNumber = A.String "N"+    toJSON AttrBinary = A.String "B"++instance A.FromJSON AttributeType where     parseJSON (A.String str) =         case str of-            "S" -> return AttrStringT-            "N" -> return AttrNumberT-            "B" -> return AttrBinaryT+            "S" -> return AttrString+            "N" -> return AttrNumber+            "B" -> return AttrBinary             _   -> fail $ "Invalid attribute type " ++ T.unpack str     parseJSON _ = fail "Attribute type must be a string"  -- | A key attribute that appears in the table key or as a key in one of the indices.-data KeyAttributeDefinition-    = KeyAttributeDefinition {-        attributeName :: T.Text-      , attributeType :: KeyAttributeType-      }-    deriving (Show, Generic)-instance A.ToJSON KeyAttributeDefinition where+data AttributeDefinition = AttributeDefinition {+      attributeName :: T.Text+    , attributeType :: AttributeType+    } deriving (Eq,Read,Ord,Show,Typeable,Generic)++instance A.ToJSON AttributeDefinition where     toJSON = A.genericToJSON capitalizeOpt-instance A.FromJSON KeyAttributeDefinition where++instance A.FromJSON AttributeDefinition where     parseJSON = A.genericParseJSON capitalizeOpt  -- | The key schema can either be a hash of a single attribute name or a hash attribute name -- and a range attribute name.-data KeySchema = KeyHashOnly T.Text-               | KeyHashAndRange T.Text T.Text-    deriving (Show)+data KeySchema = HashOnly T.Text+               | HashAndRange T.Text T.Text+    deriving (Eq,Read,Show,Ord,Typeable,Generic)++ instance A.ToJSON KeySchema where-    toJSON (KeyHashOnly attr) -        = A.Array $ V.fromList [ A.object [ "AttributeName" .= attr-                                          , "KeyType" .= ("HASH" :: T.Text)+    toJSON (HashOnly a)+        = A.Array $ V.fromList [ A.object [ "AttributeName" .= a+                                          , "KeyType" .= (A.String "HASH")                                           ]                                ]-    toJSON (KeyHashAndRange hash range) ++    toJSON (HashAndRange hash range)         = A.Array $ V.fromList [ A.object [ "AttributeName" .= hash-                                          , "KeyType" .= ("HASH" :: T.Text)+                                          , "KeyType" .= (A.String "HASH")                                           ]                                , A.object [ "AttributeName" .= range-                                          , "KeyType" .= ("RANGE" :: T.Text)+                                          , "KeyType" .= (A.String "RANGE")                                           ]                                ]+ instance A.FromJSON KeySchema where     parseJSON (A.Array v) =         case V.length v of@@ -106,7 +123,7 @@                     kt <- obj .: "KeyType"                     if kt /= ("HASH" :: T.Text)                         then fail "With only one key, the type must be HASH"-                        else KeyHashOnly <$> obj .: "AttributeName"+                        else HashOnly <$> obj .: "AttributeName"              2 -> do hash <- A.parseJSON (v V.! 0)                     range <- A.parseJSON (v V.! 1)@@ -114,8 +131,8 @@                     rkt <- range .: "KeyType"                     if hkt /= ("HASH" :: T.Text) || rkt /= ("RANGE" :: T.Text)                         then fail "With two keys, one must be HASH and the other RANGE"-                        else KeyHashAndRange <$> hash .: "AttributeName"-                                             <*> range .: "AttributeName"+                        else HashAndRange <$> hash .: "AttributeName"+                                          <*> range .: "AttributeName"             _ -> fail "Key schema must have one or two entries"     parseJSON _ = fail "Key schema must be an array" @@ -139,13 +156,14 @@             "INCLUDE" -> ProjectInclude <$> o .: "NonKeyAttributes"             _ -> fail "Invalid projection type"     parseJSON _ = fail "Projection must be an object"-      --- | Describes a single local secondary index.  The KeySchema MUST share the same hash key attribute--- as the parent table, only the range key can differ.++-- | Describes a single local secondary index. The KeySchema MUST+-- share the same hash key attribute as the parent table, only the+-- range key can differ. data LocalSecondaryIndex     = LocalSecondaryIndex {-        localIndexName :: T.Text-      , localKeySchema :: KeySchema+        localIndexName  :: T.Text+      , localKeySchema  :: KeySchema       , localProjection :: Projection       }     deriving (Show, Generic)@@ -157,11 +175,11 @@ -- | This is returned by AWS to describe the local secondary index. data LocalSecondaryIndexStatus     = LocalSecondaryIndexStatus {-        locStatusIndexName :: T.Text+        locStatusIndexName      :: T.Text       , locStatusIndexSizeBytes :: Integer-      , locStatusItemCount :: Integer-      , locStatusKeySchema :: KeySchema-      , locStatusProjection :: Projection+      , locStatusItemCount      :: Integer+      , locStatusKeySchema      :: KeySchema+      , locStatusProjection     :: Projection       }     deriving (Show, Generic) instance A.FromJSON LocalSecondaryIndexStatus where@@ -170,7 +188,7 @@ -- | The target provisioned throughput you are requesting for the table or global secondary index. data ProvisionedThroughput     = ProvisionedThroughput {-        readCapacityUnits :: Int+        readCapacityUnits  :: Int       , writeCapacityUnits :: Int       }     deriving (Show, Generic)@@ -182,11 +200,11 @@ -- | This is returned by AWS as the status of the throughput for a table or global secondary index. data ProvisionedThroughputStatus     = ProvisionedThroughputStatus {-        statusLastDecreaseDateTime :: UTCTime-      , statusLastIncreaseDateTime :: UTCTime+        statusLastDecreaseDateTime   :: UTCTime+      , statusLastIncreaseDateTime   :: UTCTime       , statusNumberOfDecreasesToday :: Int-      , statusReadCapacityUnits :: Int-      , statusWriteCapacityUnits :: Int+      , statusReadCapacityUnits      :: Int+      , statusWriteCapacityUnits     :: Int       }     deriving (Show, Generic) instance A.FromJSON ProvisionedThroughputStatus where@@ -201,9 +219,9 @@ -- | Describes a global secondary index. data GlobalSecondaryIndex     = GlobalSecondaryIndex {-        globalIndexName :: T.Text-      , globalKeySchema :: KeySchema-      , globalProjection :: Projection+        globalIndexName             :: T.Text+      , globalKeySchema             :: KeySchema+      , globalProjection            :: Projection       , globalProvisionedThroughput :: ProvisionedThroughput       }     deriving (Show, Generic)@@ -215,44 +233,46 @@ -- | This is returned by AWS to describe the status of a global secondary index. data GlobalSecondaryIndexStatus     = GlobalSecondaryIndexStatus {-        gStatusIndexName :: T.Text-      , gStatusIndexSizeBytes :: Integer-      , gStatusIndexStatus :: T.Text-      , gStatusItemCount :: Integer-      , gStatusKeySchema :: KeySchema-      , gStatusProjection :: Projection+        gStatusIndexName             :: T.Text+      , gStatusIndexSizeBytes        :: Integer+      , gStatusIndexStatus           :: T.Text+      , gStatusItemCount             :: Integer+      , gStatusKeySchema             :: KeySchema+      , gStatusProjection            :: Projection       , gStatusProvisionedThroughput :: ProvisionedThroughputStatus       }     deriving (Show, Generic) instance A.FromJSON GlobalSecondaryIndexStatus where     parseJSON = A.genericParseJSON $ dropOpt 7 --- | This is used to request a change in the provisioned throughput of a global secondary index as--- part of an 'UpdateTable' operation.+-- | This is used to request a change in the provisioned throughput of+-- a global secondary index as part of an 'UpdateTable' operation. data GlobalSecondaryIndexUpdate     = GlobalSecondaryIndexUpdate {-        gUpdateIndexName :: T.Text+        gUpdateIndexName             :: T.Text       , gUpdateProvisionedThroughput :: ProvisionedThroughput       }     deriving (Show, Generic) instance A.ToJSON GlobalSecondaryIndexUpdate where     toJSON gi = A.object ["Update" .= A.genericToJSON (dropOpt 7) gi] --- | This describes the table and is the return value from AWS for all the table-related commands.+-- | This describes the table and is the return value from AWS for all+-- the table-related commands. data TableDescription     = TableDescription {-        rTableName :: T.Text-      , rTableSizeBytes :: Integer-      , rTableStatus :: T.Text -- ^ one of CREATING, UPDATING, DELETING, ACTIVE-      , rCreationDateTime :: UTCTime-      , rItemCount :: Integer-      , rAttributeDefinitions :: [KeyAttributeDefinition]-      , rKeySchema :: KeySchema-      , rProvisionedThroughput :: ProvisionedThroughputStatus-      , rLocalSecondaryIndexes :: [LocalSecondaryIndexStatus]+        rTableName              :: T.Text+      , rTableSizeBytes         :: Integer+      , rTableStatus            :: T.Text -- ^ one of CREATING, UPDATING, DELETING, ACTIVE+      , rCreationDateTime       :: UTCTime+      , rItemCount              :: Integer+      , rAttributeDefinitions   :: [AttributeDefinition]+      , rKeySchema              :: KeySchema+      , rProvisionedThroughput  :: ProvisionedThroughputStatus+      , rLocalSecondaryIndexes  :: [LocalSecondaryIndexStatus]       , rGlobalSecondaryIndexes :: [GlobalSecondaryIndexStatus]       }     deriving (Show, Generic)+ instance A.FromJSON TableDescription where     parseJSON = A.withObject "Table must be an object" $ \o -> do         t <- case (M.lookup "Table" o, M.lookup "TableDescription" o) of@@ -269,11 +289,11 @@                          <*> t .: "ProvisionedThroughput"                          <*> t .:? "LocalSecondaryIndexes" .!= []                          <*> t .:? "GlobalSecondaryIndexes" .!= []-             + {- Can't derive these instances onto the return values instance ResponseConsumer r TableDescription where     type ResponseMetadata TableDescription = DyMetadata-    responseConsumer _ _ = dyResponseConsumer+    responseConsumer _ _ = ddbResponseConsumer instance AsMemoryResponse TableDescription where     type MemoryResponse TableDescription = TableDescription     loadToMemory = return@@ -283,16 +303,24 @@ --- Commands ------------------------------------------------------------------------------- -data CreateTable-    = CreateTable {-        createTableName :: T.Text-      , createAttributeDefinitions :: [KeyAttributeDefinition] -- ^ only attributes appearing in a key must be listed here-      , createKeySchema :: KeySchema-      , createProvisionedThroughput :: ProvisionedThroughput-      , createLocalSecondaryIndexes :: [LocalSecondaryIndex] -- ^ at most 5 local secondary indices are allowed-      , createGlobalSecondaryIndexes :: [GlobalSecondaryIndex]-      }-    deriving (Show, Generic)+data CreateTable = CreateTable {+      createTableName              :: T.Text+    , createAttributeDefinitions   :: [AttributeDefinition]+    -- ^ only attributes appearing in a key must be listed here+    , createKeySchema              :: KeySchema+    , createProvisionedThroughput  :: ProvisionedThroughput+    , createLocalSecondaryIndexes  :: [LocalSecondaryIndex]+    -- ^ at most 5 local secondary indices are allowed+    , createGlobalSecondaryIndexes :: [GlobalSecondaryIndex]+    } deriving (Show, Generic)++createTable :: T.Text -- ^ Table name+            -> [AttributeDefinition]+            -> KeySchema+            -> ProvisionedThroughput+            -> CreateTable+createTable tn ad ks p = CreateTable tn ad ks p [] []+ instance A.ToJSON CreateTable where     toJSON ct = A.object $ m ++ lindex ++ gindex         where@@ -308,20 +336,22 @@             gindex = if null (createGlobalSecondaryIndexes ct)                         then []                         else [ "GlobalSecondaryIndexes" .= createGlobalSecondaryIndexes ct ]+ --instance A.ToJSON CreateTable where --    toJSON = A.genericToJSON $ dropOpt 6-        --- | ServiceConfiguration: 'DyConfiguration'+++-- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery CreateTable where-    type ServiceConfiguration CreateTable = DyConfiguration-    signQuery = dySignQuery "CreateTable"+    type ServiceConfiguration CreateTable = DdbConfiguration+    signQuery = ddbSignQuery "CreateTable"  newtype CreateTableResult = CreateTableResult { ctStatus :: TableDescription }     deriving (Show, A.FromJSON) -- ResponseConsumer and AsMemoryResponse can't be derived instance ResponseConsumer r CreateTableResult where-    type ResponseMetadata CreateTableResult = DyMetadata-    responseConsumer _ _ = dyResponseConsumer+    type ResponseMetadata CreateTableResult = DdbResponse+    responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse CreateTableResult where     type MemoryResponse CreateTableResult = TableDescription     loadToMemory = return . ctStatus@@ -330,23 +360,23 @@  data DescribeTable     = DescribeTable {-        dTableName :: T.Text +        dTableName :: T.Text       }     deriving (Show, Generic) instance A.ToJSON DescribeTable where     toJSON = A.genericToJSON $ dropOpt 1 --- | ServiceConfiguration: 'DyConfiguration'+-- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery DescribeTable where-    type ServiceConfiguration DescribeTable = DyConfiguration-    signQuery = dySignQuery "DescribeTable"+    type ServiceConfiguration DescribeTable = DdbConfiguration+    signQuery = ddbSignQuery "DescribeTable"  newtype DescribeTableResult = DescribeTableResult { dtStatus :: TableDescription }     deriving (Show, A.FromJSON) -- ResponseConsumer can't be derived instance ResponseConsumer r DescribeTableResult where-    type ResponseMetadata DescribeTableResult = DyMetadata-    responseConsumer _ _ = dyResponseConsumer+    type ResponseMetadata DescribeTableResult = DdbResponse+    responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse DescribeTableResult where     type MemoryResponse DescribeTableResult = TableDescription     loadToMemory = return . dtStatus@@ -355,25 +385,25 @@  data UpdateTable     = UpdateTable {-        updateTableName :: T.Text-      , updateProvisionedThroughput :: ProvisionedThroughput+        updateTableName                   :: T.Text+      , updateProvisionedThroughput       :: ProvisionedThroughput       , updateGlobalSecondaryIndexUpdates :: [GlobalSecondaryIndexUpdate]       }     deriving (Show, Generic) instance A.ToJSON UpdateTable where     toJSON = A.genericToJSON $ dropOpt 6-    --- | ServiceConfiguration: 'DyConfiguration'++-- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery UpdateTable where-    type ServiceConfiguration UpdateTable = DyConfiguration-    signQuery = dySignQuery "UpdateTable"+    type ServiceConfiguration UpdateTable = DdbConfiguration+    signQuery = ddbSignQuery "UpdateTable"  newtype UpdateTableResult = UpdateTableResult { uStatus :: TableDescription }     deriving (Show, A.FromJSON) -- ResponseConsumer can't be derived instance ResponseConsumer r UpdateTableResult where-    type ResponseMetadata UpdateTableResult = DyMetadata-    responseConsumer _ _ = dyResponseConsumer+    type ResponseMetadata UpdateTableResult = DdbResponse+    responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse UpdateTableResult where     type MemoryResponse UpdateTableResult = TableDescription     loadToMemory = return . uStatus@@ -388,17 +418,17 @@ instance A.ToJSON DeleteTable where     toJSON = A.genericToJSON $ dropOpt 6 --- | ServiceConfiguration: 'DyConfiguration'+-- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery DeleteTable where-    type ServiceConfiguration DeleteTable = DyConfiguration-    signQuery = dySignQuery "DeleteTable"+    type ServiceConfiguration DeleteTable = DdbConfiguration+    signQuery = ddbSignQuery "DeleteTable"  newtype DeleteTableResult = DeleteTableResult { dStatus :: TableDescription }     deriving (Show, A.FromJSON) -- ResponseConsumer can't be derived instance ResponseConsumer r DeleteTableResult where-    type ResponseMetadata DeleteTableResult = DyMetadata-    responseConsumer _ _ = dyResponseConsumer+    type ResponseMetadata DeleteTableResult = DdbResponse+    responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse DeleteTableResult where     type MemoryResponse DeleteTableResult = TableDescription     loadToMemory = return . dStatus@@ -410,23 +440,23 @@     deriving (Show) instance A.ToJSON ListTables where     toJSON _ = A.object []--- | ServiceConfiguration: 'DyConfiguration'+-- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery ListTables where-    type ServiceConfiguration ListTables = DyConfiguration-    signQuery = dySignQuery "ListTables"+    type ServiceConfiguration ListTables = DdbConfiguration+    signQuery = ddbSignQuery "ListTables"  newtype ListTablesResult     = ListTablesResult {-        tableNames :: [T.Text] +        tableNames :: [T.Text]       }     deriving (Show, Generic) instance A.FromJSON ListTablesResult where     parseJSON = A.genericParseJSON capitalizeOpt instance ResponseConsumer r ListTablesResult where-    type ResponseMetadata ListTablesResult = DyMetadata-    responseConsumer _ _ = dyResponseConsumer+    type ResponseMetadata ListTablesResult = DdbResponse+    responseConsumer _ = ddbResponseConsumer instance AsMemoryResponse ListTablesResult where-    type MemoryResponse ListTablesResult = [T.Text] +    type MemoryResponse ListTablesResult = [T.Text]     loadToMemory = return . tableNames  instance Transaction ListTables ListTablesResult
+ Aws/DynamoDb/Commands/UpdateItem.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.UpdateItem+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability   :  experimental+--+--+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.UpdateItem where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import qualified Data.Text           as T+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-- | An @UpdateItem@ request.+data UpdateItem = UpdateItem {+      uiTable   :: T.Text+    , uiKey     :: PrimaryKey+    , uiUpdates :: [AttributeUpdate]+    , uiExpect  :: Conditions+    -- ^ Conditional update - see DynamoDb documentation+    , uiReturn  :: UpdateReturn+    , uiRetCons :: ReturnConsumption+    , uiRetMet  :: ReturnItemCollectionMetrics+    } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'UpdateItem' request.+updateItem+    :: T.Text                   -- ^ Table name+    -> PrimaryKey               -- ^ Primary key for item+    -> [AttributeUpdate]        -- ^ Updates for this item+    -> UpdateItem+updateItem tn key ups = UpdateItem tn key ups def def def def+++type AttributeUpdates = [AttributeUpdate]+++data AttributeUpdate = AttributeUpdate {+      auAttr   :: Attribute+    -- ^ Attribute key-value+    , auAction :: UpdateAction+    -- ^ Type of update operation.+    } deriving (Eq,Show,Read,Ord)+++instance DynSize AttributeUpdate where+    dynSize (AttributeUpdate a _) = dynSize a++-------------------------------------------------------------------------------+-- | Shorthand for the 'AttributeUpdate' constructor. Defaults to PUT+-- for the update action.+au :: Attribute -> AttributeUpdate+au a = AttributeUpdate a def+++instance ToJSON AttributeUpdates where+    toJSON = object . map mk+        where+          mk AttributeUpdate{..} = (attrName auAttr) .= object+            ["Value" .= (attrVal auAttr), "Action" .= auAction]+++-------------------------------------------------------------------------------+-- | Type of attribute update to perform.+--+-- See AWS docs at:+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_UpdateItem.html@+data UpdateAction+    = UPut                      -- ^ Simpley write, overwriting any previous value+    | UAdd                      -- ^ Numerical add or add to set.+    | UDelete                   -- ^ Empty value: remove; Set value: Subtract from set.+    deriving (Eq,Show,Read,Ord)+++instance ToJSON UpdateAction where+    toJSON UPut = String "PUT"+    toJSON UAdd = String "ADD"+    toJSON UDelete = String "DELETE"+++instance Default UpdateAction where+    def = UPut+++instance ToJSON UpdateItem where+    toJSON UpdateItem{..} =+        object $ expectsJson uiExpect +++          [ "TableName" .= uiTable+          , "Key" .= uiKey+          , "AttributeUpdates" .= uiUpdates+          , "ReturnValues" .= uiReturn+          , "ReturnConsumedCapacity" .= uiRetCons+          , "ReturnItemCollectionMetrics" .= uiRetMet+          ]+++data UpdateItemResponse = UpdateItemResponse {+      uirAttrs    :: Maybe Item+    -- ^ Old attributes, if requested+    , uirConsumed :: Maybe ConsumedCapacity+    -- ^ Amount of capacity consumed+    } deriving (Eq,Show,Read,Ord)++++instance Transaction UpdateItem UpdateItemResponse+++instance SignQuery UpdateItem where+    type ServiceConfiguration UpdateItem = DdbConfiguration+    signQuery gi = ddbSignQuery "UpdateItem" gi+++instance FromJSON UpdateItemResponse where+    parseJSON (Object v) = UpdateItemResponse+        <$> v .:? "Attributes"+        <*> v .:? "ConsumedCapacity"+    parseJSON _ = fail "UpdateItemResponse expected a JSON object"+++instance ResponseConsumer r UpdateItemResponse where+    type ResponseMetadata UpdateItemResponse = DdbResponse+    responseConsumer _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse UpdateItemResponse where+    type MemoryResponse UpdateItemResponse = UpdateItemResponse+    loadToMemory = return++++++++
Aws/DynamoDb/Core.hs view
@@ -1,126 +1,1136 @@-module Aws.DynamoDb.Core where--import           Aws.Core-import qualified Control.Exception              as C-import           Control.Monad.Trans.Resource   (throwM)-import           Crypto.Hash-import           Data.Byteable-import qualified Data.Aeson                     as A-import qualified Data.ByteString                as B-import qualified Data.ByteString.Base16         as Base16-import           Data.Conduit-import qualified Data.Conduit.Attoparsec        as Atto-import           Data.Monoid-import           Data.Typeable-import qualified Network.HTTP.Conduit           as HTTP-import qualified Network.HTTP.Types             as HTTP--type ErrorCode = String--data DyError-    = DyError {-        dyStatusCode :: HTTP.Status-      , dyErrorCode :: ErrorCode-      , dyErrorMessage :: String-      }-    deriving (Show, Typeable)--instance C.Exception DyError--data DyMetadata = DyMetadata-    deriving (Show, Typeable)--instance Loggable DyMetadata where-    toLogText DyMetadata = "DynamoDB"--instance Monoid DyMetadata where-    mempty = DyMetadata-    DyMetadata `mappend` DyMetadata = DyMetadata--data DyConfiguration qt-    = DyConfiguration {-        dyProtocol :: Protocol-      , dyHost :: B.ByteString-      , dyPort :: Int-      , dyRegion :: B.ByteString-      }-    deriving (Show)--instance DefaultServiceConfiguration (DyConfiguration NormalQuery) where-  defServiceConfig = dyHttp dyUsEast-  debugServiceConfig = dyLocal--dyUsEast :: (B.ByteString, B.ByteString)-dyUsEast = ("us-east-1", "dynamodb.us-east-1.amazonaws.com")--dyHttp :: (B.ByteString, B.ByteString) -> DyConfiguration qt-dyHttp (region, endpoint) = DyConfiguration HTTP endpoint (defaultPort HTTP) region--dyHttps :: (B.ByteString, B.ByteString) -> DyConfiguration qt-dyHttps (region, endpoint) = DyConfiguration HTTPS endpoint (defaultPort HTTPS) region--dyLocal :: DyConfiguration qt-dyLocal = DyConfiguration HTTP "localhost" 8000 "local"--dyApiVersion :: B.ByteString-dyApiVersion = "DynamoDB_20120810."--dySignQuery :: A.ToJSON a => B.ByteString -> a -> DyConfiguration qt -> SignatureData -> SignedQuery-dySignQuery target body di sd-    = SignedQuery {-        sqMethod = Post-      , sqProtocol = dyProtocol di-      , sqHost = dyHost di-      , sqPort = dyPort di-      , sqPath = "/"-      , sqQuery = []-      , sqDate = Just $ signatureTime sd-      , sqAuthorization = Just auth-      , sqContentType = Just "application/x-amz-json-1.0"-      , sqContentMd5 = Nothing-      , sqAmzHeaders = [ ("X-Amz-Target", dyApiVersion <> target)-                       , ("X-Amz-Date", sigTime)-                       ]-      , sqOtherHeaders = []-      , sqBody = Just $ HTTP.RequestBodyLBS bodyLBS-      , sqStringToSign = canonicalRequest-      }-    where-        sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd--        bodyLBS = A.encode body-        bodyHash = Base16.encode $ toBytes (hashlazy bodyLBS :: Digest SHA256)--        canonicalRequest = B.concat [ "POST\n"-                                    , "/\n"-                                    , "\n" -- query string-                                    , "content-type:application/x-amz-json-1.0\n"-                                    , "host:"-                                    , dyHost di-                                    , "\n"-                                    , "x-amz-date:"-                                    , sigTime-                                    , "\n"-                                    , "x-amz-target:"-                                    , dyApiVersion-                                    , target-                                    , "\n"-                                    , "\n" -- end headers-                                    , "content-type;host;x-amz-date;x-amz-target\n"-                                    , bodyHash-                                    ]--        auth = authorizationV4 sd HmacSHA256 (dyRegion di) "dynamodb"-                               "content-type;host;x-amz-date;x-amz-target"-                               canonicalRequest--dyResponseConsumer :: A.FromJSON a-                   => HTTPResponseConsumer a-dyResponseConsumer resp = do-    val <- HTTP.responseBody resp $$+- Atto.sinkParser A.json'-    case HTTP.responseStatus resp of-        (HTTP.Status{HTTP.statusCode=200}) -> do-            case A.fromJSON val of-                A.Success a -> return a-                A.Error err -> throwM $ DyError (HTTP.responseStatus resp) "" err-        _ -> throwM $ DyError (HTTP.responseStatus resp) "" (show val)+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Core+-- Copyright   :  Soostone Inc, Chris Allen+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman, Chris Allen+-- Stability   :  experimental+--+-- Shared types and utilities for DyanmoDb functionality.+----------------------------------------------------------------------------++module Aws.DynamoDb.Core+    (+    -- * Configuration and Regions+      Region (..)+    , ddbLocal+    , ddbUsEast1+    , ddbUsWest1+    , ddbUsWest2+    , ddbEuWest1+    , ddbApNe1+    , ddbApSe1+    , ddbApSe2+    , ddbSaEast1+    , DdbConfiguration (..)++    -- * DynamoDB values+    , DValue (..)++    -- * Converting to/from 'DValue'+    , DynVal(..)+    , toValue, fromValue+    , Bin (..)++    -- * Defining new 'DynVal' instances+    , DynData(..)+    , DynBinary(..), DynNumber(..), DynString(..)++    -- * Working with key/value pairs+    , Attribute (..)+    , parseAttributeJson+    , attributeJson+    , attributesJson++    , attrTuple+    , attr+    , attrAs+    , text, int, double+    , PrimaryKey (..)+    , hk+    , hrk++    -- * Working with objects (attribute collections)+    , Item+    , item+    , attributes++    -- * Common types used by operations+    , Conditions (..)+    , conditionsJson+    , expectsJson++    , Condition (..)+    , conditionJson+    , CondOp (..)+    , CondMerge (..)+    , ConsumedCapacity (..)+    , ReturnConsumption (..)+    , ItemCollectionMetrics (..)+    , ReturnItemCollectionMetrics (..)+    , UpdateReturn (..)+    , QuerySelect+    , querySelectJson++    -- * Size estimation+    , DynSize (..)+    , nullAttr++    -- * Responses & Errors+    , DdbResponse (..)+    , DdbErrCode (..)+    , shouldRetry+    , DdbError (..)++    -- * Internal Helpers+    , ddbSignQuery+    , AmazonError (..)+    , ddbResponseConsumer+    , ddbHttp+    , ddbHttps++    ) where+++-------------------------------------------------------------------------------+import           Control.Applicative+import qualified Control.Exception            as C+import           Control.Monad+import           Control.Monad.Trans+import           Control.Monad.Trans.Resource (throwM)+import           Crypto.Hash+import           Data.Aeson+import qualified Data.Aeson                   as A+import           Data.Aeson.Types             (Pair, parseEither)+import qualified Data.Aeson.Types             as A+import qualified Data.Attoparsec.Text         as Atto+import           Data.Byteable+import qualified Data.ByteString.Base16       as Base16+import qualified Data.ByteString.Base64       as Base64+import qualified Data.ByteString.Char8        as B+import           Data.Conduit+import           Data.Conduit.Attoparsec      (sinkParser)+import           Data.Default+import qualified Data.HashMap.Strict          as HM+import           Data.Int+import           Data.IORef+import qualified Data.Map                     as M+import           Data.Maybe+import           Data.Monoid+import           Data.Proxy+import           Data.Scientific+import qualified Data.Serialize               as Ser+import qualified Data.Set                     as S+import           Data.String+import qualified Data.Text                    as T+import qualified Data.Text.Encoding           as T+import           Data.Time+import           Data.Typeable+import           Data.Word+import qualified Network.HTTP.Conduit         as HTTP+import qualified Network.HTTP.Types           as HTTP+import           Safe+-------------------------------------------------------------------------------+import           Aws.Core+-------------------------------------------------------------------------------++++-------------------------------------------------------------------------------+-- | Numeric values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynNumber = DynNumber { unDynNumber :: Scientific }+    deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | String values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynString = DynString { unDynString :: T.Text }+    deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | Binary values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynBinary = DynBinary { unDynBinary :: B.ByteString }+    deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | An internally used closed typeclass for values that have direct+-- DynamoDb representations. Based on AWS API, this is basically+-- numbers, strings and binary blobs.+--+-- This is here so that any 'DynVal' haskell value can automatically+-- be lifted to a list or a 'Set' without any instance code+-- duplication.+--+-- Do not try to create your own instances.+class Ord a => DynData a where+    fromData :: a -> DValue+    toData :: DValue -> Maybe a++instance DynData DynNumber where+    fromData (DynNumber i) = DNum i+    toData (DNum i) = Just $ DynNumber i+    toData _ = Nothing++instance DynData (S.Set DynNumber) where+    fromData set = DNumSet (S.map unDynNumber set)+    toData (DNumSet i) = Just $ S.map DynNumber i+    toData _ = Nothing++instance DynData DynString where+    fromData (DynString i) = DString i+    toData (DString i) = Just $ DynString i+    toData _ = Nothing++instance DynData (S.Set DynString) where+    fromData set = DStringSet (S.map unDynString set)+    toData (DStringSet i) = Just $ S.map DynString i+    toData _ = Nothing++instance DynData DynBinary where+    fromData (DynBinary i) = DBinary i+    toData (DBinary i) = Just $ DynBinary i+    toData _ = Nothing++instance DynData (S.Set DynBinary) where+    fromData set = DBinSet (S.map unDynBinary set)+    toData (DBinSet i) = Just $ S.map DynBinary i+    toData _ = Nothing++instance DynData DValue where+    fromData = id+    toData = Just+++-------------------------------------------------------------------------------+-- | Class of Haskell types that can be represented as DynamoDb values.+--+-- This is the conversion layer; instantiate this class for your own+-- types and then use the 'toValue' and 'fromValue' combinators to+-- convert in application code.+--+-- Each Haskell type instantiated with this class will map to a+-- DynamoDb-supported type that most naturally represents it.+class DynData (DynRep a) => DynVal a where++    -- | Which of the 'DynData' instances does this data type directly+    -- map to?+    type DynRep a++    -- | Convert to representation+    toRep :: a -> DynRep a++    -- | Convert from representation+    fromRep :: DynRep a -> Maybe a+++-------------------------------------------------------------------------------+-- | Any singular 'DynVal' can be upgraded to a list.+instance (DynData (DynRep [a]), DynVal a) => DynVal [a] where+    type DynRep [a] = S.Set (DynRep a)+    fromRep set = mapM fromRep $ S.toList set+    toRep as = S.fromList $ map toRep as+++-------------------------------------------------------------------------------+-- | Any singular 'DynVal' can be upgraded to a 'Set'.+instance (DynData (DynRep (S.Set a)), DynVal a, Ord a) => DynVal (S.Set a) where+    type DynRep (S.Set a) = S.Set (DynRep a)+    fromRep set = fmap S.fromList . mapM fromRep $ S.toList set+    toRep as = S.map toRep as+++instance DynVal DValue where+    type DynRep DValue = DValue+    fromRep = Just+    toRep   = id+++instance DynVal Int where+    type DynRep Int = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Int8 where+    type DynRep Int8 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Int16 where+    type DynRep Int16 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Int32 where+    type DynRep Int32 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Int64 where+    type DynRep Int64 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Word8 where+    type DynRep Word8 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Word16 where+    type DynRep Word16 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Word32 where+    type DynRep Word32 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Word64 where+    type DynRep Word64 = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal Integer where+    type DynRep Integer = DynNumber+    fromRep (DynNumber i) = toIntegral i+    toRep i = DynNumber (fromIntegral i)+++instance DynVal T.Text where+    type DynRep T.Text = DynString+    fromRep (DynString i) = Just i+    toRep i = DynString i+++instance DynVal B.ByteString where+    type DynRep B.ByteString = DynBinary+    fromRep (DynBinary i) = Just i+    toRep i = DynBinary i+++instance DynVal Double where+    type DynRep Double = DynNumber+    fromRep (DynNumber i) = Just $ toRealFloat i+    toRep i = DynNumber (fromFloatDigits i)+++-------------------------------------------------------------------------------+-- | Encoded as number of days+instance DynVal Day where+    type DynRep Day = DynNumber+    fromRep (DynNumber i) = ModifiedJulianDay <$> (toIntegral i)+    toRep (ModifiedJulianDay i) = DynNumber (fromIntegral i)+++-------------------------------------------------------------------------------+-- | Losslessly encoded via 'Integer' picoseconds+instance DynVal UTCTime where+    type DynRep UTCTime = DynNumber+    fromRep num = fromTS <$> fromRep num+    toRep x = toRep (toTS x)+++-------------------------------------------------------------------------------+pico :: Integer+pico = 10 ^ (12 :: Integer)+++-------------------------------------------------------------------------------+dayPico :: Integer+dayPico = 86400 * pico+++-------------------------------------------------------------------------------+-- | Convert UTCTime to picoseconds+--+-- TODO: Optimize performance?+toTS :: UTCTime -> Integer+toTS (UTCTime (ModifiedJulianDay i) diff) = i' + diff'+    where+      diff' = floor (toRational diff * pico')+      pico' = toRational pico+      i' = i * dayPico+++-------------------------------------------------------------------------------+-- | Convert picoseconds to UTCTime+--+-- TODO: Optimize performance?+fromTS :: Integer -> UTCTime+fromTS i = UTCTime (ModifiedJulianDay days) diff+    where+      (days, secs) = i `divMod` dayPico+      diff = fromRational ((toRational secs) / toRational pico)+++-- | Encoded as 0 and 1.+instance DynVal Bool where+    type DynRep Bool = DynNumber+    fromRep (DynNumber i) = do+        (i' :: Int) <- toIntegral i+        case i' of+          0 -> return False+          1 -> return True+          _ -> Nothing+    toRep b = DynNumber (if b then 1 else 0)++++-- | Type wrapper for binary data to be written to DynamoDB. Wrap any+-- 'Serialize' instance in there and 'DynVal' will know how to+-- automatically handle conversions in binary form.+newtype Bin a = Bin a deriving (Eq,Show,Read,Ord)+++instance (Ser.Serialize a) => DynVal (Bin a) where+    type DynRep (Bin a) = DynBinary+    toRep (Bin i) = DynBinary (Ser.encode i)+    fromRep (DynBinary i) = either (const Nothing) (Just . Bin) $+                            Ser.decode i++++-------------------------------------------------------------------------------+-- | Encode a Haskell value.+toValue :: DynVal a  => a -> DValue+toValue a = fromData $ toRep a+++-------------------------------------------------------------------------------+-- | Decode a Haskell value.+fromValue :: DynVal a => DValue -> Maybe a+fromValue d = toData d >>= fromRep+++toIntegral :: (Integral a, RealFrac a1) => a1 -> Maybe a+toIntegral sc = Just $ floor sc++++-- | Value types natively recognized by DynamoDb. We pretty much+-- exactly reflect the AWS API onto Haskell types.+data DValue+    = DNum Scientific+    | DString T.Text+    | DBinary B.ByteString+    -- ^ Binary data will automatically be base64 marshalled.+    | DNumSet (S.Set Scientific)+    | DStringSet (S.Set T.Text)+    | DBinSet (S.Set B.ByteString)+    -- ^ Binary data will automatically be base64 marshalled.+    deriving (Eq,Show,Read,Ord,Typeable)+++instance IsString DValue where+    fromString t = DString (T.pack t)++-------------------------------------------------------------------------------+-- | Primary keys consist of either just a Hash key (mandatory) or a+-- hash key and a range key (optional).+data PrimaryKey = PrimaryKey {+      pkHash  :: Attribute+    , pkRange :: Maybe Attribute+    } deriving (Read,Show,Ord,Eq,Typeable)+++-------------------------------------------------------------------------------+-- | Construct a hash-only primary key.+--+-- >>> hk "user-id" "ABCD"+--+-- >>> hk "user-id" (mkVal 23)+hk :: T.Text -> DValue -> PrimaryKey+hk k v = PrimaryKey (attr k v) Nothing+++-------------------------------------------------------------------------------+-- | Construct a hash-and-range primary key.+hrk :: T.Text                   -- ^ Hash key name+    -> DValue                   -- ^ Hash key value+    -> T.Text                   -- ^ Range key name+    -> DValue                   -- ^ Range key value+    -> PrimaryKey+hrk k v k2 v2 = PrimaryKey (attr k v) (Just (attr k2 v2))+++instance ToJSON PrimaryKey where+    toJSON (PrimaryKey h Nothing) = toJSON h+    toJSON (PrimaryKey h (Just r)) =+      let Object p1 = toJSON h+          Object p2 = toJSON r+      in Object (p1 `HM.union` p2)+++-- | A key-value pair+data Attribute = Attribute {+      attrName :: T.Text+    , attrVal  :: DValue+    } deriving (Read,Show,Ord,Eq,Typeable)+++-- | Convert attribute to a tuple representation+attrTuple :: Attribute -> (T.Text, DValue)+attrTuple (Attribute a b) = (a,b)+++-- | Convenience function for constructing key-value pairs+attr :: DynVal a => T.Text -> a -> Attribute+attr k v = Attribute k (toValue v)+++-- | 'attr' with type witness to help with cases where you're manually+-- supplying values in code.+--+-- >> item [ attrAs text "name" "john" ]+attrAs :: DynVal a => Proxy a -> T.Text -> a -> Attribute+attrAs _ k v = attr k v+++-- | Type witness for 'Text'. See 'attrAs'.+text :: Proxy T.Text+text = Proxy+++-- | Type witness for 'Integer'. See 'attrAs'.+int :: Proxy Integer+int = Proxy+++-- | Type witness for 'Double'. See 'attrAs'.+double :: Proxy Double+double = Proxy+++-- | A DynamoDb object is simply a key-value dictionary.+type Item = M.Map T.Text DValue+++-------------------------------------------------------------------------------+-- | Pack a list of attributes into an Item.+item :: [Attribute] -> Item+item = M.fromList . map attrTuple+++-------------------------------------------------------------------------------+-- | Unpack an 'Item' into a list of attributes.+attributes :: M.Map T.Text DValue -> [Attribute]+attributes = map (\ (k, v) -> Attribute k v) . M.toList+++showT :: Show a => a -> T.Text+showT = T.pack . show++instance ToJSON DValue where+    toJSON (DNum i) = object ["N" .= showT i]+    toJSON (DString i) = object ["S" .= i]+    toJSON (DBinary i) = object ["B" .= (T.decodeUtf8 $ Base64.encode i)]+    toJSON (DNumSet i) = object ["NS" .= map showT (S.toList i)]+    toJSON (DStringSet i) = object ["SS" .= S.toList i]+    toJSON (DBinSet i) = object ["BS" .= map (T.decodeUtf8 . Base64.encode) (S.toList i)]+    toJSON x = error $ "aws: bug: DynamoDB can't handle " ++ show x+++instance FromJSON DValue where+    parseJSON o = do+      (obj :: [(T.Text, Value)]) <- M.toList `liftM` parseJSON o+      case obj of+        [("N", numStr)] -> DNum <$> parseScientific numStr+        [("S", str)] -> DString <$> parseJSON str+        [("B", bin)] -> do+            res <- (Base64.decode . T.encodeUtf8) <$> parseJSON bin+            either fail (return . DBinary) res+        [("NS", s)] -> do xs <- mapM parseScientific =<< parseJSON s+                          return $ DNumSet $ S.fromList xs+        [("SS", s)] -> DStringSet <$> parseJSON s+        [("BS", s)] -> do+            xs <- mapM (either fail return . Base64.decode . T.encodeUtf8)+                  =<< parseJSON s+            return $ DBinSet $ S.fromList xs++        x -> fail $ "aws: unknown dynamodb value: " ++ show x++      where+        parseScientific (String str) =+            case Atto.parseOnly Atto.scientific str of+              Left e -> fail ("parseScientific failed: " ++ e)+              Right a -> return a+        parseScientific (Number n) = return n+        parseScientific _ = fail "Unexpected JSON type in parseScientific"+++instance ToJSON Attribute where+    toJSON a = object $ [attributeJson a]+++-------------------------------------------------------------------------------+-- | Parse a JSON object that contains attributes+parseAttributeJson :: Value -> A.Parser [Attribute]+parseAttributeJson (Object v) = mapM conv $ HM.toList v+    where+      conv (k, o) = Attribute k <$> parseJSON o+parseAttributeJson _ = error "Attribute JSON must be an Object"+++-- | Convert into JSON object for AWS.+attributesJson :: [Attribute] -> Value+attributesJson as = object $ map attributeJson as+++-- | Convert into JSON pair+attributeJson :: Attribute -> Pair+attributeJson (Attribute nm v) = nm .= v+++-------------------------------------------------------------------------------+-- | Errors defined by AWS.+data DdbErrCode+    = AccessDeniedException+    | ConditionalCheckFailedException+    | IncompleteSignatureException+    | InvalidSignatureException+    | LimitExceededException+    | MissingAuthenticationTokenException+    | ProvisionedThroughputExceededException+    | ResourceInUseException+    | ResourceNotFoundException+    | ThrottlingException+    | ValidationException+    | RequestTooLarge+    | InternalFailure+    | InternalServerError+    | ServiceUnavailableException+    | SerializationException+    -- ^ Raised by AWS when the request JSON is missing fields or is+    -- somehow malformed.+    deriving (Read,Show,Eq,Typeable)+++-------------------------------------------------------------------------------+-- | Whether the action should be retried based on the received error.+shouldRetry :: DdbErrCode -> Bool+shouldRetry e = go e+    where+      go LimitExceededException = True+      go ProvisionedThroughputExceededException = True+      go ResourceInUseException = True+      go ThrottlingException = True+      go InternalFailure = True+      go InternalServerError = True+      go ServiceUnavailableException = True+      go _ = False+++-------------------------------------------------------------------------------+-- | Errors related to this library.+data DdbLibraryError+    = UnknownDynamoErrCode T.Text+    -- ^ A DynamoDB error code we do not know about.+    | JsonProtocolError Value T.Text+    -- ^ A JSON response we could not parse.+    deriving (Show,Eq,Typeable)+++-- | Potential errors raised by DynamoDB+data DdbError = DdbError {+      ddbStatusCode :: Int+    -- ^ 200 if successful, 400 for client errors and 500 for+    -- server-side errors.+    , ddbErrCode    :: DdbErrCode+    , ddbErrMsg     :: T.Text+    } deriving (Show,Eq,Typeable)+++instance C.Exception DdbError+instance C.Exception DdbLibraryError+++-- | Response metadata that is present in every DynamoDB response.+data DdbResponse = DdbResponse {+      ddbrCrc   :: Maybe T.Text+    , ddbrMsgId :: Maybe T.Text+    }+++instance Loggable DdbResponse where+    toLogText (DdbResponse id2 rid) =+        "DynamoDB: request ID=" `mappend`+        fromMaybe "<none>" rid `mappend`+        ", x-amz-id-2=" `mappend`+        fromMaybe "<none>" id2++instance Monoid DdbResponse where+    mempty = DdbResponse Nothing Nothing+    mappend a b = DdbResponse (ddbrCrc a `mplus` ddbrCrc b) (ddbrMsgId a `mplus` ddbrMsgId b)+++data Region = Region {+      rUri  :: B.ByteString+    , rName :: B.ByteString+    } deriving (Eq,Show,Read,Typeable)+++data DdbConfiguration qt = DdbConfiguration {+      ddbcRegion   :: Region+    -- ^ The regional endpoint. Ex: 'ddbUsEast'+    , ddbcProtocol :: Protocol+    -- ^ 'HTTP' or 'HTTPS'+    , ddbcPort     :: Maybe Int+    -- ^ Port override (mostly for local dev connection)+    } deriving (Show,Typeable)++instance Default (DdbConfiguration NormalQuery) where+    def = DdbConfiguration ddbUsEast1 HTTPS Nothing++instance DefaultServiceConfiguration (DdbConfiguration NormalQuery) where+  defServiceConfig = ddbHttps ddbUsEast1+  debugServiceConfig = ddbHttp ddbUsEast1+++-------------------------------------------------------------------------------+-- | DynamoDb local connection (for development)+ddbLocal :: Region+ddbLocal = Region "127.0.0.1" "local"++ddbUsEast1 :: Region+ddbUsEast1 = Region "dynamodb.us-east-1.amazonaws.com" "us-east-1"++ddbUsWest1 :: Region+ddbUsWest1 = Region "dynamodb.us-west-1.amazonaws.com" "us-west-1"++ddbUsWest2 :: Region+ddbUsWest2 = Region "dynamodb.us-west-2.amazonaws.com" "us-west-2"++ddbEuWest1 :: Region+ddbEuWest1 = Region "dynamodb.eu-west-1.amazonaws.com" "us-west-1"++ddbApNe1 :: Region+ddbApNe1 = Region "dynamodb.ap-northeast-1.amazonaws.com" "ap-northeast-1"++ddbApSe1 :: Region+ddbApSe1 = Region "dynamodb.ap-southeast-1.amazonaws.com" "ap-southeast-1"++ddbApSe2 :: Region+ddbApSe2 = Region "dynamodb.ap-southeast-2.amazonaws.com" "ap-southeast-2"++ddbSaEast1 :: Region+ddbSaEast1 = Region "dynamodb.sa-east-1.amazonaws.com" "sa-east-1"++ddbHttp :: Region -> DdbConfiguration NormalQuery+ddbHttp endpoint = DdbConfiguration endpoint HTTP Nothing++ddbHttps :: Region -> DdbConfiguration NormalQuery+ddbHttps endpoint = DdbConfiguration endpoint HTTPS Nothing+++ddbSignQuery+    :: A.ToJSON a+    => B.ByteString+    -> a+    -> DdbConfiguration qt+    -> SignatureData+    -> SignedQuery+ddbSignQuery target body di sd+    = SignedQuery {+        sqMethod = Post+      , sqProtocol = ddbcProtocol di+      , sqHost = host+      , sqPort = fromMaybe (defaultPort (ddbcProtocol di)) (ddbcPort di)+      , sqPath = "/"+      , sqQuery = []+      , sqDate = Just $ signatureTime sd+      , sqAuthorization = Just auth+      , sqContentType = Just "application/x-amz-json-1.0"+      , sqContentMd5 = Nothing+      , sqAmzHeaders = [ ("X-Amz-Target", dyApiVersion <> target)+                       , ("X-Amz-Date", sigTime)+                       ]+      , sqOtherHeaders = []+      , sqBody = Just $ HTTP.RequestBodyLBS bodyLBS+      , sqStringToSign = canonicalRequest+      }+    where++        Region{..} = ddbcRegion di+        host = rUri++        sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd++        bodyLBS = A.encode body+        bodyHash = Base16.encode $ toBytes (hashlazy bodyLBS :: Digest SHA256)++        canonicalRequest = B.concat [ "POST\n"+                                    , "/\n"+                                    , "\n" -- query string+                                    , "content-type:application/x-amz-json-1.0\n"+                                    , "host:"+                                    , host+                                    , "\n"+                                    , "x-amz-date:"+                                    , sigTime+                                    , "\n"+                                    , "x-amz-target:"+                                    , dyApiVersion+                                    , target+                                    , "\n"+                                    , "\n" -- end headers+                                    , "content-type;host;x-amz-date;x-amz-target\n"+                                    , bodyHash+                                    ]++        auth = authorizationV4 sd HmacSHA256 rName "dynamodb"+                               "content-type;host;x-amz-date;x-amz-target"+                               canonicalRequest++data AmazonError = AmazonError {+      aeType    :: T.Text+    , aeMessage :: Maybe T.Text+    }++instance FromJSON AmazonError where+    parseJSON (Object v) = AmazonError+        <$> v .: "__type"+        <*> v .:? "message"+    parseJSON _ = error $ "aws: unexpected AmazonError message"+++++-------------------------------------------------------------------------------+ddbResponseConsumer :: A.FromJSON a => IORef DdbResponse -> HTTPResponseConsumer a+ddbResponseConsumer ref resp = do+    val <- HTTP.responseBody resp $$+- sinkParser A.json'+    case statusCode of+      200 -> rSuccess val+      _   -> rError val+  where++    header = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)+    amzId = header "x-amzn-RequestId"+    amzCrc = header "x-amz-crc32"+    meta = DdbResponse amzCrc amzId+    tellMeta = liftIO $ tellMetadataRef ref meta++    rSuccess val =+      case A.fromJSON val of+        A.Success a -> return a+        A.Error err -> do+            tellMeta+            throwM $ JsonProtocolError val (T.pack err)++    rError val = do+      tellMeta+      case parseEither parseJSON val of+        Left e ->+          throwM $ JsonProtocolError val (T.pack e)++        Right err'' -> do+          let e = T.drop 1 . snd . T.breakOn "#" $ aeType err''+          errCode <- readErrCode e+          throwM $ DdbError statusCode errCode (fromMaybe "" $ aeMessage err'')++    readErrCode txt =+        let txt' = T.unpack txt+        in case readMay txt' of+             Just e -> return $ e+             Nothing -> throwM (UnknownDynamoErrCode txt)++    HTTP.Status{..} = HTTP.responseStatus resp+++-- | Conditions used by mutation operations ('PutItem', 'UpdateItem',+-- etc.). The default 'def' instance is empty (no condition).+data Conditions = Conditions CondMerge [Condition]+    deriving (Eq,Show,Read,Ord,Typeable)++instance Default Conditions where+    def = Conditions CondAnd []++++expectsJson :: Conditions -> [A.Pair]+expectsJson = conditionsJson "Expected"+++-- | JSON encoding of conditions parameter in various contexts.+conditionsJson :: T.Text -> Conditions -> [A.Pair]+conditionsJson key (Conditions op es) = b ++ a+    where+      a = if null es+          then []+          else [key .= object (map conditionJson es)]++      b = if length (take 2 es) > 1+          then ["ConditionalOperator" .= String (rendCondOp op) ]+          else []+++-------------------------------------------------------------------------------+rendCondOp :: CondMerge -> T.Text+rendCondOp CondAnd = "AND"+rendCondOp CondOr = "OR"+++-------------------------------------------------------------------------------+-- | How to merge multiple conditions.+data CondMerge = CondAnd | CondOr+    deriving (Eq,Show,Read,Ord,Typeable)+++-- | A condition used by mutation operations ('PutItem', 'UpdateItem', etc.).+data Condition = Condition {+      condAttr :: T.Text+    -- ^ Attribute to use as the basis for this conditional+    , condOp   :: CondOp+    -- ^ Operation on the selected attribute+    } deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | Conditional operation to perform on a field.+data CondOp+    = DEq DValue+    | NotEq DValue+    | DLE DValue+    | DLT DValue+    | DGE DValue+    | DGT DValue+    | NotNull+    | IsNull+    | Contains DValue+    | NotContains DValue+    | Begins DValue+    | In [DValue]+    | Between DValue DValue+    deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+getCondValues :: CondOp -> [DValue]+getCondValues c = case c of+    DEq v -> [v]+    NotEq v -> [v]+    DLE v -> [v]+    DLT v -> [v]+    DGE v -> [v]+    DGT v -> [v]+    NotNull -> []+    IsNull -> []+    Contains v -> [v]+    NotContains v -> [v]+    Begins v -> [v]+    In v -> v+    Between a b -> [a,b]+++-------------------------------------------------------------------------------+renderCondOp :: CondOp -> T.Text+renderCondOp c = case c of+    DEq{} -> "EQ"+    NotEq{} -> "NE"+    DLE{} -> "LE"+    DLT{} -> "LT"+    DGE{} -> "GE"+    DGT{} -> "GT"+    NotNull -> "NOT_NULL"+    IsNull -> "NULL"+    Contains{} -> "CONTAINS"+    NotContains{} -> "NOT_CONTAINS"+    Begins{} -> "BEGINS_WITH"+    In{} -> "IN"+    Between{} -> "BETWEEN"+++conditionJson :: Condition -> Pair+conditionJson Condition{..} = condAttr .= condOp+++instance ToJSON CondOp where+    toJSON c = object+      [ "ComparisonOperator" .= String (renderCondOp c)+      , "AttributeValueList" .= getCondValues c ]+++-------------------------------------------------------------------------------+dyApiVersion :: B.ByteString+dyApiVersion = "DynamoDB_20120810."++++-------------------------------------------------------------------------------+-- | The standard response metrics on capacity consumption.+data ConsumedCapacity = ConsumedCapacity {+      capacityUnits       :: Int64+    , capacityGlobalIndex :: [(T.Text, Int64)]+    , capacityLocalIndex  :: [(T.Text, Int64)]+    , capacityTableUnits  :: Maybe Int64+    , capacityTable       :: T.Text+    } deriving (Eq,Show,Read,Ord,Typeable)+++instance FromJSON ConsumedCapacity where+    parseJSON (Object v) = ConsumedCapacity+      <$> v .: "CapacityUnits"+      <*> (HM.toList <$> v .:? "GlobalSecondaryIndexes" .!= mempty)+      <*> (HM.toList <$> v .:? "LocalSecondaryIndexes" .!= mempty)+      <*> (v .:? "Table" >>= maybe (return Nothing) (.: "CapacityUnits"))+      <*> v .: "TableName"+    parseJSON _ = fail "ConsumedCapacity must be an Object."++++data ReturnConsumption = RCIndexes | RCTotal | RCNone+    deriving (Eq,Show,Read,Ord,Typeable)++instance ToJSON ReturnConsumption where+    toJSON RCIndexes = String "INDEXES"+    toJSON RCTotal = String "TOTAL"+    toJSON RCNone = String "NONE"++instance Default ReturnConsumption where+    def = RCNone++data ReturnItemCollectionMetrics = RICMSize | RICMNone+    deriving (Eq,Show,Read,Ord,Typeable)++instance ToJSON ReturnItemCollectionMetrics where+    toJSON RICMSize = String "SIZE"+    toJSON RICMNone = String "NONE"++instance Default ReturnItemCollectionMetrics where+    def = RICMNone+++data ItemCollectionMetrics = ItemCollectionMetrics {+      icmKey      :: (T.Text, DValue)+    , icmEstimate :: [Double]+    } deriving (Eq,Show,Read,Ord,Typeable)+++instance FromJSON ItemCollectionMetrics where+    parseJSON (Object v) = ItemCollectionMetrics+      <$> (do m <- v .: "ItemCollectionKey"+              return $ head $ HM.toList m)+      <*> v .: "SizeEstimateRangeGB"+    parseJSON _ = fail "ItemCollectionMetrics must be an Object."+++-------------------------------------------------------------------------------+-- | What to return from the current update operation+data UpdateReturn+    = URNone                    -- ^ Return nothing+    | URAllOld                  -- ^ Return old values+    | URUpdatedOld              -- ^ Return old values with a newer replacement+    | URAllNew                  -- ^ Return new values+    | URUpdatedNew              -- ^ Return new values that were replacements+    deriving (Eq,Show,Read,Ord,Typeable)+++instance ToJSON UpdateReturn where+    toJSON URNone = toJSON (String "NONE")+    toJSON URAllOld = toJSON (String "ALL_OLD")+    toJSON URUpdatedOld = toJSON (String "UPDATED_OLD")+    toJSON URAllNew = toJSON (String "ALL_NEW")+    toJSON URUpdatedNew = toJSON (String "UPDATED_NEW")+++instance Default UpdateReturn where+    def = URNone++++-------------------------------------------------------------------------------+-- | What to return from a 'Query' or 'Scan' query.+data QuerySelect+    = SelectSpecific [T.Text]+    -- ^ Only return selected attributes+    | SelectCount+    -- ^ Return counts instead of attributes+    | SelectProjected+    -- ^ Return index-projected attributes+    | SelectAll+    -- ^ Default. Return everything.+    deriving (Eq,Show,Read,Ord,Typeable)+++instance Default QuerySelect where def = SelectAll++-------------------------------------------------------------------------------+querySelectJson (SelectSpecific as) =+    [ "Select" .= String "SPECIFIC_ATTRIBUTES"+    , "AttributesToGet" .= as]+querySelectJson SelectCount = ["Select" .= String "COUNT"]+querySelectJson SelectProjected = ["Select" .= String "ALL_PROJECTED_ATTRIBUTES"]+querySelectJson SelectAll = ["Select" .= String "ALL_ATTRIBUTES"]+++-------------------------------------------------------------------------------+-- | A class to help predict DynamoDb size of values, attributes and+-- entire items. The result is given in number of bytes.+class DynSize a where+    dynSize :: a -> Int++instance DynSize DValue where+    dynSize (DNum _) = 8+    dynSize (DString a) = T.length a+    dynSize (DBinary bs) = T.length . T.decodeUtf8 $ Base64.encode bs+    dynSize (DNumSet s) = 8 * S.size s+    dynSize (DStringSet s) = sum $ map (dynSize . DString) $ S.toList s+    dynSize (DBinSet s) = sum $ map (dynSize . DBinary) $ S.toList s++instance DynSize Attribute where+    dynSize (Attribute k v) = T.length k + dynSize v++instance DynSize Item where+    dynSize m = sum $ map dynSize $ attributes m++instance DynSize a => DynSize [a] where+    dynSize as = sum $ map dynSize as++instance DynSize a => DynSize (Maybe a) where+    dynSize = maybe 0 dynSize++instance (DynSize a, DynSize b) => DynSize (Either a b) where+    dynSize = either dynSize dynSize+++-------------------------------------------------------------------------------+-- | Will an attribute be considered empty by DynamoDb?+--+-- A 'PutItem' (or similar) with empty attributes will be rejection+-- with a 'ValidationException'.+nullAttr :: Attribute -> Bool+nullAttr (Attribute _ val) =+    case val of+      DString "" -> True+      DBinary "" -> True+      DNumSet s | S.null s -> True+      DStringSet s | S.null s -> True+      DBinSet s | S.null s -> True+      _ -> False++
Aws/S3/Commands.hs view
@@ -5,6 +5,7 @@ , module Aws.S3.Commands.DeleteObject , module Aws.S3.Commands.DeleteObjects , module Aws.S3.Commands.GetBucket+, module Aws.S3.Commands.GetBucketLocation , module Aws.S3.Commands.GetObject , module Aws.S3.Commands.GetService , module Aws.S3.Commands.HeadObject@@ -18,6 +19,7 @@ import Aws.S3.Commands.DeleteObject import Aws.S3.Commands.DeleteObjects import Aws.S3.Commands.GetBucket+import Aws.S3.Commands.GetBucketLocation import Aws.S3.Commands.GetObject import Aws.S3.Commands.GetService import Aws.S3.Commands.HeadObject
Aws/S3/Commands/CopyObject.hs view
@@ -6,6 +6,7 @@ import           Control.Applicative import           Control.Arrow (second) import           Control.Monad.Trans.Resource (throwM)+import qualified Data.ByteString as B import qualified Data.CaseInsensitive as CI import           Data.Maybe import qualified Data.Text as T@@ -28,13 +29,14 @@                              , coIfModifiedSince :: Maybe UTCTime                              , coStorageClass :: Maybe StorageClass                              , coAcl :: Maybe CannedAcl+                             , coContentType :: Maybe B.ByteString                              }   deriving (Show)  copyObject :: Bucket -> T.Text -> ObjectId -> CopyMetadataDirective -> CopyObject-copyObject bucket obj src meta = CopyObject obj bucket src meta Nothing Nothing Nothing Nothing Nothing Nothing+copyObject bucket obj src meta = CopyObject obj bucket src meta Nothing Nothing Nothing Nothing Nothing Nothing Nothing -data CopyObjectResponse +data CopyObjectResponse   = CopyObjectResponse {       corVersionId :: Maybe T.Text     , corLastModified :: UTCTime@@ -51,7 +53,7 @@                                , s3QObject = Just $ T.encodeUtf8 coObjectName                                , s3QSubresources = []                                , s3QQuery = []-                               , s3QContentType = Nothing+                               , s3QContentType = coContentType                                , s3QContentMd5 = Nothing                                , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [                                    Just ("x-amz-copy-source",@@ -98,7 +100,7 @@               lastMod <- forceM "Missing Last-Modified" $ el $/ elContent "LastModified" &| (parseHttpDate' . T.unpack)               etag <- force "Missing ETag" $ el $/ elContent "ETag"               return (lastMod, etag)-      +  instance Transaction CopyObject CopyObjectResponse
+ Aws/S3/Commands/GetBucketLocation.hs view
@@ -0,0 +1,56 @@+module Aws.S3.Commands.GetBucketLocation+       where++import           Aws.Core+import           Aws.S3.Core++import qualified Data.ByteString.Char8 as B8++import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HTTP+import           Text.XML.Cursor (($.//))++data GetBucketLocation+  = GetBucketLocation {+      gblBucket :: Bucket+    } deriving Show++getBucketLocation :: Bucket -> GetBucketLocation+getBucketLocation bucket+  = GetBucketLocation {+      gblBucket = bucket+    }++data GetBucketLocationResponse+  = GetBucketLocationResponse { gblrLocationConstraint :: LocationConstraint }+    deriving Show++instance SignQuery GetBucketLocation where+  type ServiceConfiguration GetBucketLocation = S3Configuration+  signQuery GetBucketLocation {..} = s3SignQuery S3Query {+                                       s3QMethod = Get+                                     , s3QBucket = Just $ T.encodeUtf8 gblBucket+                                     , s3QObject = Nothing+                                     , s3QSubresources = [("location" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+                                     , s3QQuery = HTTP.toQuery ([] :: [(B8.ByteString, T.Text)]) +                                     , s3QContentType = Nothing+                                     , s3QContentMd5 = Nothing+                                     , s3QAmzHeaders = []+                                     , s3QOtherHeaders = []+                                     , s3QRequestBody = Nothing+                                     }++instance ResponseConsumer r GetBucketLocationResponse where+  type ResponseMetadata GetBucketLocationResponse = S3Metadata++  responseConsumer _ = s3XmlResponseConsumer parse+    where parse cursor = do+            locationConstraint <- force "Missing Location" $ cursor $.// elContent "LocationConstraint"+            return GetBucketLocationResponse { gblrLocationConstraint = normaliseLocation locationConstraint }++instance Transaction GetBucketLocation GetBucketLocationResponse++instance AsMemoryResponse GetBucketLocationResponse where+  type MemoryResponse GetBucketLocationResponse = GetBucketLocationResponse+  loadToMemory = return
Aws/S3/Commands/HeadObject.hs view
@@ -4,6 +4,7 @@ import           Aws.Core import           Aws.S3.Core import           Control.Applicative+import           Control.Monad.Trans.Resource (throwM) import           Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Char8 as B8 import qualified Data.Text             as T@@ -24,11 +25,11 @@  data HeadObjectResponse     = HeadObjectResponse {-        horMetadata :: ObjectMetadata+        horMetadata :: Maybe ObjectMetadata       }  data HeadObjectMemoryResponse-    = HeadObjectMemoryResponse ObjectMetadata+    = HeadObjectMemoryResponse (Maybe ObjectMetadata)     deriving (Show)  -- | ServiceConfiguration: 'S3Configuration'@@ -52,7 +53,13 @@ instance ResponseConsumer HeadObject HeadObjectResponse where     type ResponseMetadata HeadObjectResponse = S3Metadata     responseConsumer HeadObject{..} _ resp-        = HeadObjectResponse <$> parseObjectMetadata (HTTP.responseHeaders resp)+        | status == HTTP.status200 = HeadObjectResponse . Just <$> parseObjectMetadata headers+        | status == HTTP.status404 = return $ HeadObjectResponse Nothing+        | otherwise = throwM $ HTTP.StatusCodeException status headers cookies+      where+        status  = HTTP.responseStatus    resp+        headers = HTTP.responseHeaders   resp+        cookies = HTTP.responseCookieJar resp  instance Transaction HeadObject HeadObjectResponse
Aws/S3/Commands/PutObject.hs view
@@ -33,7 +33,8 @@ #else   poRequestBody  :: HTTP.RequestBody (C.ResourceT IO), #endif-  poMetadata :: [(T.Text,T.Text)]+  poMetadata :: [(T.Text,T.Text)],+  poAutoMakeBucket :: Bool -- ^ Internet Archive S3 nonstandard extension }  #if MIN_VERSION_http_conduit(2, 0, 0)@@ -41,7 +42,7 @@ #else putObject :: Bucket -> T.Text -> HTTP.RequestBody (C.ResourceT IO) -> PutObject #endif-putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body []+putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False  data PutObjectResponse   = PutObjectResponse {@@ -64,6 +65,7 @@                                             , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass                                             , ("x-amz-website-redirect-location",) <$> poWebsiteRedirectLocation                                             , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> poServerSideEncryption+					    , if poAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1")  else Nothing                                             ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata                                , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [                                               ("Expires",) . T.pack . show <$> poExpires
Aws/S3/Core.hs view
@@ -438,7 +438,7 @@  type LocationConstraint = T.Text -locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationApSouthEast, locationApSouthEast2, locationApNorthEast :: LocationConstraint+locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint locationUsClassic = "" locationUsWest = "us-west-1" locationUsWest2 = "us-west-2"@@ -446,4 +446,9 @@ locationApSouthEast = "ap-southeast-1" locationApSouthEast2 = "ap-southeast-2" locationApNorthEast = "ap-northeast-1"+locationSA = "sa-east-1" +normaliseLocation :: LocationConstraint -> LocationConstraint+normaliseLocation location+  | location == "eu-west-1" = locationEu+  | otherwise = location
Aws/Sqs/Commands/Message.hs view
@@ -1,43 +1,242 @@+module Aws.Sqs.Commands.Message+(+-- * User Message Attributes+  UserMessageAttributeCustomType+, UserMessageAttributeValue(..)+, UserMessageAttributeName+, UserMessageAttribute -module Aws.Sqs.Commands.Message where+-- * Send Message+, SendMessage(..)+, SendMessageResponse(..) -import           Aws.Core-import           Aws.Sqs.Core-import           Control.Applicative-import           Control.Monad.Trans.Resource (MonadThrow)-import           Data.Maybe-import           Text.XML.Cursor       (($/), ($//), (&/), (&|))+-- * Delete Message+, DeleteMessage(..)+, DeleteMessageResponse(..)++-- * Receive Message+, Message(..)+, ReceiveMessage(..)+, ReceiveMessageResponse(..)++-- * Change Message Visiblity+, ChangeMessageVisibility(..)+, ChangeMessageVisibilityResponse(..)+) where++import Aws.Core+import Aws.Sqs.Core+import Control.Applicative+import Control.Monad.Trans.Resource (throwM)+import Data.Maybe+import Data.Monoid+import Text.XML.Cursor (($/), ($//), (&/), (&|))+import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B-import qualified Data.Text             as T-import qualified Data.Text.Encoding    as TE-import qualified Text.XML.Cursor       as Cu+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Scientific+import qualified Network.HTTP.Types as HTTP+import Text.Read (readEither)+import qualified Text.XML.Cursor as Cu -data SendMessage = SendMessage{-  smMessage :: T.Text,-  smQueueName :: QueueName-}deriving (Show)+-- -------------------------------------------------------------------------- --+-- User Message Attributes -data SendMessageResponse = SendMessageResponse{-  smrMD5OfMessageBody :: T.Text,-  smrMessageId :: MessageId-} deriving (Show)+-- | You can append a custom type label to the supported data types (String,+-- Number, and Binary) to create custom data types. This capability is similar+-- to type traits in programming languages. For example, if you have an+-- application that needs to know which type of number is being sent in the+-- message, then you could create custom types similar to the following:+-- Number.byte, Number.short, Number.int, and Number.float. Another example+-- using the binary data type is to use Binary.gif and Binary.png to+-- distinguish among different image file types in a message or batch of+-- messages. The appended data is optional and opaque to Amazon SQS, which+-- means that the appended data is not interpreted, validated, or used by+-- Amazon SQS. The Custom Type extension has the same restrictions on allowed+-- characters as the message body.+--+type UserMessageAttributeCustomType = T.Text +-- | Message Attribute Value+--+-- The user-specified message attribute value. For string data types, the value+-- attribute has the same restrictions on the content as the message body. For+-- more information, see SendMessage.+--+-- Name, type, and value must not be empty or null. In addition, the message+-- body should not be empty or null. All parts of the message attribute,+-- including name, type, and value, are included in the message size+-- restriction, which is currently 256 KB (262,144 bytes).+--+-- The supported message attribute data types are String, Number, and Binary.+-- You can also provide custom information on the type. The data type has the+-- same restrictions on the content as the message body. The data type is case+-- sensitive, and it can be up to 256 bytes long.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_MessageAttributeValue.html>+--+data UserMessageAttributeValue+    = UserMessageAttributeString (Maybe UserMessageAttributeCustomType) T.Text+    -- ^ Strings are Unicode with UTF-8 binary encoding.++    | UserMessageAttributeNumber (Maybe UserMessageAttributeCustomType) Scientific+    -- ^ Numbers are positive or negative integers or floating point numbers.+    -- Numbers have sufficient range and precision to encompass most of the+    -- possible values that integers, floats, and doubles typically support. A+    -- number can have up to 38 digits of precision, and it can be between+    -- 10^-128 to 10^+126. Leading and trailing zeroes are trimmed.++    | UserMessageAttributeBinary (Maybe UserMessageAttributeCustomType) B.ByteString+    -- ^ Binary type attributes can store any binary data, for example,+    -- compressed data, encrypted data, or images.++    -- UserMessageAttributesStringList (Maybe UserMessageAttributeCustomType) [T.Text]+    -- -- ^ Not implemented. Reserved for future use.++    -- UserMessageAttributeBinaryList (Maybe UserMessageAttributeCustomType) [B.ByteString]+    -- -- ^ Not implemented. Reserved for future use.++    deriving (Show, Read, Eq, Ord)++-- | The message attribute name can contain the following characters: A-Z, a-z,+-- 0-9, underscore(_), hyphen(-), and period (.). The name must not start or+-- end with a period, and it should not have successive periods. The name is+-- case sensitive and must be unique among all attribute names for the message.+-- The name can be up to 256 characters long. The name cannot start with "AWS."+-- or "Amazon." (or any variations in casing) because these prefixes are+-- reserved for use by Amazon Web Services.+--+type UserMessageAttributeName = T.Text++-- | Message Attribute+--+-- Name, type, and value must not be empty or null. In addition, the message+-- body should not be empty or null. All parts of the message attribute,+-- including name, type, and value, are included in the message size+-- restriction, which is currently 256 KB (262,144 bytes).+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/latest/SQSDeveloperGuide/SQSMessageAttributes.html#SQSMessageAttributes.DataTypes>+--+-- /NOTE/+--+-- The Amazon SQS API reference calls this /MessageAttribute/. The Haskell+-- bindings use this term for what the Amazon documentation calls just+-- /Attributes/. In order to limit backward compatibility issues we keep the+-- terminology of the Haskell bindings and call this type+-- /UserMessageAttributes/.+--+type UserMessageAttribute = (UserMessageAttributeName, UserMessageAttributeValue)++userMessageAttributesQuery :: [UserMessageAttribute] -> HTTP.Query+userMessageAttributesQuery = concat . zipWith msgAttrQuery [1 :: Int ..]+  where+    msgAttrQuery i (name, value) =+        [ ( pre <> ".Name", Just $ TE.encodeUtf8 name )+        , ( pre <> ".Value.DataType", Just typ )+        , ( pre <> ".Value." <> valueKey, Just encodedValue )+        ]+      where+        pre = "MessageAttribute." <> B.pack (show i) <> "."+        customType Nothing t = TE.encodeUtf8 t+        customType (Just c) t = TE.encodeUtf8 $ t <> "." <> c+        (typ, valueKey, encodedValue) = case value of+            UserMessageAttributeString c t ->+                (customType c "String", "StringValue", TE.encodeUtf8 t)+            UserMessageAttributeNumber c n ->+                (customType c "Number", "StringValue", B.pack $ show n)+            UserMessageAttributeBinary  c b ->+                (customType c "Binary", "BinaryValue", b)++-- -------------------------------------------------------------------------- --+-- Send Message++-- | Delivers a message to the specified queue. With Amazon SQS, you now have+-- the ability to send large payload messages that are up to 256KB (262,144+-- bytes) in size. To send large payloads, you must use an AWS SDK that+-- supports SigV4 signing. To verify whether SigV4 is supported for an AWS SDK,+-- check the SDK release notes.+--+-- /IMPORTANT/+--+-- The following list shows the characters (in Unicode) allowed in your+-- message, according to the W3C XML specification. For more information, go to+-- <http://www.w3.org/TR/REC-xml/#charsets> If you send any characters not+-- included in the list, your request will be rejected.+--+-- > #x9 | #xA | #xD | [#x20 to #xD7FF] | [#xE000 to #xFFFD] | [#x10000 to #x10FFFF]+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_SendMessage.html>+--+data SendMessage = SendMessage+    { smMessage :: !T.Text+    -- ^ The message to send. String maximum 256 KB in size.++    , smQueueName :: !QueueName+    -- ^ The URL of the Amazon SQS queue to take action on.++    , smAttributes :: ![UserMessageAttribute]+    -- ^ Each message attribute consists of a Name, Type, and Value.++    , smDelaySeconds :: !(Maybe Int)+    -- ^ The number of seconds (0 to 900 - 15 minutes) to delay a specific+    -- message. Messages with a positive DelaySeconds value become available for+    -- processing after the delay time is finished. If you don't specify a value,+    -- the default value for the queue applies.+    }+    deriving (Show, Read, Eq, Ord)++-- | At+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_SendMessageResult.html>+-- all fields of @SendMessageResult@ are denoted as optional.+-- At+-- <http://queue.amazonaws.com/doc/2012-11-05/QueueService.wsdl>+-- all fields are specified as required.+--+-- The actual service seems to treat at least 'smrMD5OfMessageAttributes'+-- as optional.+--+data SendMessageResponse = SendMessageResponse+    { smrMD5OfMessageBody :: !T.Text+    -- ^ An MD5 digest of the non-URL-encoded message body string. This can be+    -- used to verify that Amazon SQS received the message correctly. Amazon SQS+    -- first URL decodes the message before creating the MD5 digest. For+    -- information about MD5, go to <http://www.faqs.org/rfcs/rfc1321.html>.++    , smrMessageId :: !MessageId+    -- ^ An element containing the message ID of the message sent to the queue.++    , smrMD5OfMessageAttributes :: !(Maybe T.Text)+    -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can+    -- be used to verify that Amazon SQS received the message correctly. Amazon+    -- SQS first URL decodes the message before creating the MD5 digest. For+    -- information about MD5, go to <http://www.faqs.org/rfcs/rfc1321.html>.+    }+    deriving (Show, Read, Eq, Ord)+ instance ResponseConsumer r SendMessageResponse where     type ResponseMetadata SendMessageResponse = SqsMetadata     responseConsumer _ = sqsXmlResponseConsumer parse       where-        parse el = do-          md5 <- force "Missing MD5 Signature" $ el $// Cu.laxElement "MD5OfMessageBody" &/ Cu.content-          mid <- force "Missing Message Id" $ el $// Cu.laxElement "MessageId" &/ Cu.content-          return SendMessageResponse { smrMD5OfMessageBody = md5, smrMessageId = MessageId mid }+        parse el = SendMessageResponse+            <$> force "Missing MD5 Signature"+                (el $// Cu.laxElement "MD5OfMessageBody" &/ Cu.content)+            <*> (fmap MessageId . force "Missing Message Id")+                (el $// Cu.laxElement "MessageId" &/ Cu.content)+            <*> (pure . listToMaybe)+                (el $// Cu.laxElement "MD5OfMessageAttributes" &/ Cu.content) --- | ServiceConfiguration: 'SqsConfiguration'-instance SignQuery SendMessage  where-    type ServiceConfiguration SendMessage  = SqsConfiguration-    signQuery SendMessage {..} = sqsSignQuery SqsQuery {-                                             sqsQueueName = Just smQueueName,-                                             sqsQuery = [("Action", Just "SendMessage"),-                                                        ("MessageBody", Just $ TE.encodeUtf8 smMessage )]}+instance SignQuery SendMessage where+    type ServiceConfiguration SendMessage = SqsConfiguration+    signQuery SendMessage{..} = sqsSignQuery SqsQuery+        { sqsQueueName = Just smQueueName+        , sqsQuery =+            [ ("Action", Just "SendMessage")+            , ("MessageBody", Just $ TE.encodeUtf8 smMessage)+            ]+            <> userMessageAttributesQuery smAttributes+            <> maybeToList (("DelaySeconds",) . Just . B.pack . show <$> smDelaySeconds)+        }  instance Transaction SendMessage SendMessageResponse @@ -45,133 +244,437 @@     type MemoryResponse SendMessageResponse = SendMessageResponse     loadToMemory = return -data DeleteMessage = DeleteMessage{-  dmReceiptHandle :: ReceiptHandle,-  dmQueueName :: QueueName -}deriving (Show)+-- -------------------------------------------------------------------------- --+-- Delete Message -data DeleteMessageResponse = DeleteMessageResponse{-} deriving (Show)+-- | Deletes the specified message from the specified queue. You specify the+-- message by using the message's receipt handle and not the message ID you+-- received when you sent the message. Even if the message is locked by another+-- reader due to the visibility timeout setting, it is still deleted from the+-- queue. If you leave a message in the queue for longer than the queue's+-- configured retention period, Amazon SQS automatically deletes it.+--+-- /NOTE/+--+-- The receipt handle is associated with a specific instance of receiving the+-- message. If you receive a message more than once, the receipt handle you get+-- each time you receive the message is different. When you request+-- DeleteMessage, if you don't provide the most recently received receipt+-- handle for the message, the request will still succeed, but the message+-- might not be deleted.+--+-- /IMPORTANT/+--+-- It is possible you will receive a message even after you have deleted it.+-- This might happen on rare occasions if one of the servers storing a copy of+-- the message is unavailable when you request to delete the message. The copy+-- remains on the server and might be returned to you again on a subsequent+-- receive request. You should create your system to be idempotent so that+-- receiving a particular message more than once is not a problem.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_DeleteMessage.html>+--+data DeleteMessage = DeleteMessage+    { dmReceiptHandle :: !ReceiptHandle+    -- ^ The receipt handle associated with the message to delete.+    , dmQueueName :: !QueueName+    -- ^ The URL of the Amazon SQS queue to take action on.+    }+    deriving (Show, Read, Eq, Ord) +data DeleteMessageResponse = DeleteMessageResponse {}+    deriving (Show, Read, Eq, Ord)+ instance ResponseConsumer r DeleteMessageResponse where     type ResponseMetadata DeleteMessageResponse = SqsMetadata     responseConsumer _ = sqsXmlResponseConsumer parse       where-        parse _ = do return DeleteMessageResponse {}-          --- | ServiceConfiguration: 'SqsConfiguration'-instance SignQuery DeleteMessage  where -    type ServiceConfiguration DeleteMessage  = SqsConfiguration-    signQuery DeleteMessage {..} = sqsSignQuery SqsQuery {-                                             sqsQueueName = Just dmQueueName, -                                             sqsQuery = [("Action", Just "DeleteMessage"), -                                                        ("ReceiptHandle", Just $ TE.encodeUtf8 $ printReceiptHandle dmReceiptHandle )]} +        parse _ = return DeleteMessageResponse {} +instance SignQuery DeleteMessage  where+    type ServiceConfiguration DeleteMessage = SqsConfiguration+    signQuery DeleteMessage{..} = sqsSignQuery SqsQuery+        { sqsQueueName = Just dmQueueName+        , sqsQuery =+            [ ("Action", Just "DeleteMessage")+            , ("ReceiptHandle", Just $ TE.encodeUtf8 $ printReceiptHandle dmReceiptHandle)+            ]+        }+ instance Transaction DeleteMessage DeleteMessageResponse  instance AsMemoryResponse DeleteMessageResponse where     type MemoryResponse DeleteMessageResponse = DeleteMessageResponse     loadToMemory = return -data ReceiveMessage-    = ReceiveMessage {-        rmVisibilityTimeout :: Maybe Int-      , rmAttributes :: [MessageAttribute]-      , rmMaxNumberOfMessages :: Maybe Int-      , rmQueueName :: QueueName-      }-    deriving (Show)+-- -------------------------------------------------------------------------- --+-- Receive Message -data Message-    = Message {-        mMessageId :: T.Text-      , mReceiptHandle :: ReceiptHandle-      , mMD5OfBody :: T.Text-      , mBody :: T.Text-      , mAttributes :: [(MessageAttribute,T.Text)]-      }-    deriving(Show)+-- | Retrieves one or more messages, with a maximum limit of 10 messages, from+-- the specified queue. Long poll support is enabled by using the+-- WaitTimeSeconds parameter. For more information, see+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/latest/SQSDeveloperGuide/sqs-long-polling.html Amazon SQS Long Poll>+-- in the Amazon SQS Developer Guide.+--+-- Short poll is the default behavior where a weighted random set of machines+-- is sampled on a ReceiveMessage call. This means only the messages on the+-- sampled machines are returned. If the number of messages in the queue is+-- small (less than 1000), it is likely you will get fewer messages than you+-- requested per ReceiveMessage call. If the number of messages in the queue is+-- extremely small, you might not receive any messages in a particular+-- ReceiveMessage response; in which case you should repeat the request.+--+-- For each message returned, the response includes the following:+--+-- Message body+--+-- * MD5 digest of the message body. For information about MD5, go to+--   <http://www.faqs.org/rfcs/rfc1321.html>.+--+-- * Message ID you received when you sent the message to the queue.+--+-- * Receipt handle.+--+-- * Message attributes.+--+-- * MD5 digest of the message attributes.+--+-- The receipt handle is the identifier you must provide when deleting the+-- message. For more information, see Queue and Message Identifiers in the+-- Amazon SQS Developer Guide.+--+-- You can provide the VisibilityTimeout parameter in your request, which will+-- be applied to the messages that Amazon SQS returns in the response. If you+-- do not include the parameter, the overall visibility timeout for the queue+-- is used for the returned messages. For more information, see Visibility+-- Timeout in the Amazon SQS Developer Guide.+--+-- /NOTE/+--+-- Going forward, new attributes might be added. If you are writing code that+-- calls this action, we recommend that you structure your code so that it can+-- handle new attributes gracefully.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_ReceiveMessage.html>+--+data ReceiveMessage = ReceiveMessage+    { rmVisibilityTimeout :: !(Maybe Int)+    -- ^ The duration (in seconds) that the received messages are hidden from+    -- subsequent retrieve requests after being retrieved by a ReceiveMessage+    -- request. -data ReceiveMessageResponse-    = ReceiveMessageResponse {-        rmrMessages :: [Message]-      }-    deriving (Show)+    , rmAttributes :: ![MessageAttribute]+    -- ^ A list of attributes that need to be returned along with each message.+    --+    -- The following lists the names and descriptions of the attributes that can+    -- be returned:+    --+    -- * All - returns all values.+    --+    -- * ApproximateFirstReceiveTimestamp - returns the time when the message was+    --   first received (epoch time in milliseconds).+    --+    -- * ApproximateReceiveCount - returns the number of times a message has been+    --   received but not deleted.+    --+    -- * SenderId - returns the AWS account number (or the IP address, if+    --   anonymous access is allowed) of the sender.+    --+    -- * SentTimestamp - returns the time when the message was sent (epoch time+    --   in milliseconds). -readMessageAttribute :: MonadThrow m => Cu.Cursor -> m (MessageAttribute,T.Text)+    , rmMaxNumberOfMessages :: !(Maybe Int)+    -- ^ The maximum number of messages to return. Amazon SQS never returns more+    -- messages than this value but may return fewer. Values can be from 1 to 10.+    -- Default is 1.+    --+    -- All of the messages are not necessarily returned.++    , rmUserMessageAttributes :: ![UserMessageAttributeName]+    -- ^ The name of the message attribute, where N is the index. The message+    -- attribute name can contain the following characters: A-Z, a-z, 0-9,+    -- underscore (_), hyphen (-), and period (.). The name must not start or end+    -- with a period, and it should not have successive periods. The name is case+    -- sensitive and must be unique among all attribute names for the message.+    -- The name can be up to 256 characters long. The name cannot start with+    -- "AWS." or "Amazon." (or any variations in casing), because these prefixes+    -- are reserved for use by Amazon Web Services.+    --+    -- When using ReceiveMessage, you can send a list of attribute names to+    -- receive, or you can return all of the attributes by specifying "All" or+    -- ".*" in your request. You can also use "foo.*" to return all message+    -- attributes starting with the "foo" prefix.++    , rmQueueName :: !QueueName+    -- ^The URL of the Amazon SQS queue to take action on.++    , rmWaitTimeSeconds :: !(Maybe Int)+    -- ^ The duration (in seconds) for which the call will wait for a message to+    -- arrive in the queue before returning. If a message is available, the call+    -- will return sooner than WaitTimeSeconds.++    }+    deriving (Show, Read, Eq, Ord)++-- | An Amazon SQS message.+--+-- In+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_Message.html>+-- all elements are denoted as optional.+-- In+-- <http://queue.amazonaws.com/doc/2012-11-05/QueueService.wsdl>+-- all elements except for the attributes are specified as required.+-- At least for the field 'mMD5OfMessageAttributes' the the service+-- is not always returning a value and therefor we make this field optional.+--+data Message = Message+    { mMessageId :: !T.Text+    -- ^ A unique identifier for the message. Message IDs are considered unique+    -- across all AWS accounts for an extended period of time.++    , mReceiptHandle :: !ReceiptHandle+    -- ^ An identifier associated with the act of receiving the message. A new+    -- receipt handle is returned every time you receive a message. When deleting+    -- a message, you provide the last received receipt handle to delete the+    -- message.++    , mMD5OfBody :: !T.Text+    -- ^ An MD5 digest of the non-URL-encoded message body string.++    , mBody :: T.Text+    -- ^ The message's contents (not URL-encoded).++    , mAttributes :: ![(MessageAttribute,T.Text)]+    -- ^ SenderId, SentTimestamp, ApproximateReceiveCount, and/or+    -- ApproximateFirstReceiveTimestamp. SentTimestamp and+    -- ApproximateFirstReceiveTimestamp are each returned as an integer+    -- representing the epoch time in milliseconds.++    , mMD5OfMessageAttributes :: !(Maybe T.Text)+    -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can+    -- be used to verify that Amazon SQS received the message correctly. Amazon+    -- SQS first URL decodes the message before creating the MD5 digest. For+    -- information about MD5, go to <http://www.faqs.org/rfcs/rfc1321.html>.++    , mUserMessageAttributes :: ![UserMessageAttribute]+    -- ^ Each message attribute consists of a Name, Type, and Value.+    }+    deriving(Show, Read, Eq, Ord)++data ReceiveMessageResponse = ReceiveMessageResponse+    { rmrMessages :: ![Message]+    }+    deriving (Show, Read, Eq, Ord)++readMessageAttribute+    :: Cu.Cursor+    -> Response SqsMetadata (MessageAttribute,T.Text) readMessageAttribute cursor = do-  name <- force "Missing Name" $ cursor $/ Cu.laxElement "Name" &/ Cu.content-  value <- force "Missing Value" $ cursor $/ Cu.laxElement "Value" &/ Cu.content-  parsedName <- parseMessageAttribute name-  return (parsedName, value)+    name <- force "Missing Name" $ cursor $/ Cu.laxElement "Name" &/ Cu.content+    value <- force "Missing Value" $ cursor $/ Cu.laxElement "Value" &/ Cu.content+    parsedName <- parseMessageAttribute name+    return (parsedName, value) -readMessage :: Cu.Cursor -> [Message]+readUserMessageAttribute+    :: Cu.Cursor+    -> Response SqsMetadata UserMessageAttribute+readUserMessageAttribute cursor = (,)+    <$> force "Missing Name" (cursor $/ Cu.laxElement "Name" &/ Cu.content)+    <*> readUserMessageAttributeValue cursor++readUserMessageAttributeValue+    :: Cu.Cursor+    -> Response SqsMetadata UserMessageAttributeValue+readUserMessageAttributeValue cursor = do+    typStr <- force "Missing DataType"+        $ cursor $/ Cu.laxElement "DataType" &/ Cu.content+    case parseType typStr of+        ("String", c) -> do+            val <- force "Missing StringValue"+                $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content+            return $ UserMessageAttributeString c val++        ("Number", c) -> do+            valStr <- force "Missing StringValue"+                $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content+            val <- tryXml . readEither $ T.unpack valStr+            return $ UserMessageAttributeNumber c val++        ("Binary", c) -> do+            val64 <- force "Missing StringValue"+                $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content+            val <- tryXml . B64.decode $ TE.encodeUtf8 val64+            return $ UserMessageAttributeBinary c val++        (x, _) -> throwM . XmlException+            $ "unkown data type for MessageAttributeValue: " <> T.unpack x+  where+    parseType s = case T.break (== '.') s of+        (a, "") -> (a, Nothing)+        (a, x) -> (a, Just (T.tail x))+    tryXml = either (throwM . XmlException) return++readMessage :: Cu.Cursor -> Response SqsMetadata Message readMessage cursor = do-  mid :: T.Text <- force "Missing Message Id" $ cursor $// Cu.laxElement "MessageId" &/ Cu.content-  rh <- force "Missing Reciept Handle" $ cursor $// Cu.laxElement "ReceiptHandle" &/ Cu.content-  md5 <- force "Missing MD5 Signature" $ cursor $// Cu.laxElement "MD5OfBody" &/ Cu.content-  body <- force "Missing Body" $ cursor $// Cu.laxElement "Body" &/ Cu.content-  let attributes :: [(MessageAttribute, T.Text)] = concat $ cursor $// Cu.laxElement "Attribute" &| readMessageAttribute+    mid <- force "Missing Message Id"+        $ cursor $// Cu.laxElement "MessageId" &/ Cu.content+    rh <- force "Missing Reciept Handle"+        $ cursor $// Cu.laxElement "ReceiptHandle" &/ Cu.content+    md5 <- force "Missing MD5 Signature"+        $ cursor $// Cu.laxElement "MD5OfBody" &/ Cu.content+    body <- force "Missing Body"+        $ cursor $// Cu.laxElement "Body" &/ Cu.content+    attributes <- sequence+        $ cursor $// Cu.laxElement "Attribute" &| readMessageAttribute+    userAttributes <- sequence+        $ cursor $// Cu.laxElement "MessageAttribute" &| readUserMessageAttribute+    let md5OfMessageAttributes = listToMaybe+            $ cursor $// Cu.laxElement "MD5OfMessageAttributes" &/ Cu.content -  return Message{ mMessageId = mid, mReceiptHandle = ReceiptHandle rh, mMD5OfBody = md5, mBody = body, mAttributes = attributes}+    return Message+        { mMessageId = mid+        , mReceiptHandle = ReceiptHandle rh+        , mMD5OfBody = md5+        , mBody = body+        , mAttributes = attributes+        , mMD5OfMessageAttributes = md5OfMessageAttributes+        , mUserMessageAttributes = userAttributes+        } -formatMAttributes :: [MessageAttribute] -> [(B.ByteString, Maybe B.ByteString)]-formatMAttributes attrs =-  case length attrs of-    0 -> []-    1 -> [("AttributeName", Just $ B.pack $ show $ attrs !! 0)]-    _ -> zipWith (\ x y -> ((B.concat ["AttributeName.", B.pack $ show $ y]), Just $ TE.encodeUtf8 $ printMessageAttribute x) ) attrs [1 :: Integer ..]+formatMAttributes :: [MessageAttribute] -> HTTP.Query+formatMAttributes attrs = case attrs of+    [attr] -> [("AttributeName", encodeAttr attr)]+    _ -> zipWith f [1 :: Int ..] attrs+  where+    f x y = ("AttributeName." <> B.pack (show x), encodeAttr y)+    encodeAttr = Just . TE.encodeUtf8 . printMessageAttribute +formatUserMessageAttributes :: [UserMessageAttributeName] -> HTTP.Query+formatUserMessageAttributes attrs = case attrs of+    [attr] -> [("MessageAttributeName", encodeAttr attr)]+    _ -> zipWith f [1 :: Int ..] attrs+  where+    f x y = ("MessageAttributeName." <> B.pack (show x), encodeAttr y)+    encodeAttr = Just . TE.encodeUtf8+ instance ResponseConsumer r ReceiveMessageResponse where     type ResponseMetadata ReceiveMessageResponse = SqsMetadata     responseConsumer _ = sqsXmlResponseConsumer parse       where         parse el = do-          let messages = concat $ el $// Cu.laxElement "Message" &| readMessage-          return ReceiveMessageResponse{ rmrMessages = messages }+            result <- force "Missing ReceiveMessageResult"+                $ el $// Cu.laxElement "ReceiveMessageResult"+            messages <- sequence+                $ result $// Cu.laxElement "Message" &| readMessage+            return ReceiveMessageResponse{ rmrMessages = messages } --- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery ReceiveMessage  where     type ServiceConfiguration ReceiveMessage  = SqsConfiguration-    signQuery ReceiveMessage {..} = sqsSignQuery SqsQuery {-                                             sqsQueueName = Just rmQueueName,-                                             sqsQuery = [("Action", Just "ReceiveMessage")] ++-                                                         catMaybes[("VisibilityTimeout",) <$> case rmVisibilityTimeout of-                                                                                                Just x -> Just $ Just $ B.pack $ show x-                                                                                                Nothing -> Nothing,-                                                                   ("MaxNumberOfMessages",) <$> case rmMaxNumberOfMessages of-                                                                                                  Just x -> Just $ Just $ B.pack $ show x-                                                                                                  Nothing -> Nothing] ++ formatMAttributes rmAttributes}+    signQuery ReceiveMessage{..} = sqsSignQuery SqsQuery+        { sqsQueueName = Just rmQueueName+        , sqsQuery = [ ("Action", Just "ReceiveMessage") ]+            <> catMaybes+                [ ("VisibilityTimeout",) <$> case rmVisibilityTimeout of+                    Just x -> Just $ Just $ B.pack $ show x+                    Nothing -> Nothing +                , ("MaxNumberOfMessages",) <$> case rmMaxNumberOfMessages of+                    Just x -> Just $ Just $ B.pack $ show x+                    Nothing -> Nothing++                , ("WaitTimeSeconds",) <$> case rmWaitTimeSeconds of+                    Just x -> Just $ Just $ B.pack $ show x+                    Nothing -> Nothing+                ]+                <> formatMAttributes rmAttributes+                <> formatUserMessageAttributes rmUserMessageAttributes+        }+ instance Transaction ReceiveMessage ReceiveMessageResponse  instance AsMemoryResponse ReceiveMessageResponse where     type MemoryResponse ReceiveMessageResponse = ReceiveMessageResponse     loadToMemory = return -data ChangeMessageVisibility = ChangeMessageVisibility {-  cmvReceiptHandle :: ReceiptHandle,-  cmvVisibilityTimeout :: Int,-  cmvQueueName :: QueueName-}deriving (Show)+-- -------------------------------------------------------------------------- --+-- Change Message Visibility -data ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse{-} deriving (Show)+-- | Changes the visibility timeout of a specified message in a queue to a new+-- value. The maximum allowed timeout value you can set the value to is 12+-- hours. This means you can't extend the timeout of a message in an existing+-- queue to more than a total visibility timeout of 12 hours. (For more+-- information visibility timeout, see Visibility Timeout in the Amazon SQS+-- Developer Guide.)+--+-- For example, let's say you have a message and its default message visibility+-- timeout is 30 minutes. You could call ChangeMessageVisiblity with a value of+-- two hours and the effective timeout would be two hours and 30 minutes. When+-- that time comes near you could again extend the time out by calling+-- ChangeMessageVisiblity, but this time the maximum allowed timeout would be 9+-- hours and 30 minutes.+--+-- /NOTE/+--+-- There is a 120,000 limit for the number of inflight messages per queue.+-- Messages are inflight after they have been received from the queue by a+-- consuming component, but have not yet been deleted from the queue. If you+-- reach the 120,000 limit, you will receive an OverLimit error message from+-- Amazon SQS. To help avoid reaching the limit, you should delete the messages+-- from the queue after they have been processed. You can also increase the+-- number of queues you use to process the messages.+--+-- /IMPORTANT/+--+-- If you attempt to set the VisibilityTimeout to an amount more than the+-- maximum time left, Amazon SQS returns an error. It will not automatically+-- recalculate and increase the timeout to the maximum time remaining.+--+-- /IMPORTANT/+--+-- Unlike with a queue, when you change the visibility timeout for a specific+-- message, that timeout value is applied immediately but is not saved in+-- memory for that message. If you don't delete a message after it is received,+-- the visibility timeout for the message the next time it is received reverts+-- to the original timeout value, not the value you set with the+-- ChangeMessageVisibility action.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_ChangeMessageVisibility.html>+--+data ChangeMessageVisibility = ChangeMessageVisibility+    { cmvReceiptHandle :: !ReceiptHandle+    -- ^ The receipt handle associated with the message whose visibility timeout+    -- should be changed. This parameter is returned by the ReceiveMessage+    -- action. +    , cmvVisibilityTimeout :: !Int+    -- ^ The new value (in seconds - from 0 to 43200 - maximum 12 hours) for the+    -- message's visibility timeout.++    , cmvQueueName :: !QueueName+    -- ^ The URL of the Amazon SQS queue to take action on.+    }+    deriving (Show, Read, Eq, Ord)++data ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse {}+    deriving (Show, Read, Eq, Ord)+ instance ResponseConsumer r ChangeMessageVisibilityResponse where     type ResponseMetadata ChangeMessageVisibilityResponse = SqsMetadata     responseConsumer _ = sqsXmlResponseConsumer parse-      where -        parse _ = do return ChangeMessageVisibilityResponse{}-    +      where+        parse _ = return ChangeMessageVisibilityResponse {}+ -- | ServiceConfiguration: 'SqsConfiguration'-instance SignQuery ChangeMessageVisibility  where +instance SignQuery ChangeMessageVisibility where     type ServiceConfiguration ChangeMessageVisibility  = SqsConfiguration-    signQuery ChangeMessageVisibility {..} = sqsSignQuery SqsQuery { -                                             sqsQueueName = Just cmvQueueName, -                                             sqsQuery = [("Action", Just "ChangeMessageVisibility"), -                                                         ("ReceiptHandle", Just $ TE.encodeUtf8 $ printReceiptHandle cmvReceiptHandle),-                                                         ("VisibilityTimeout", Just $ B.pack $ show cmvVisibilityTimeout)]}+    signQuery ChangeMessageVisibility {..} = sqsSignQuery SqsQuery+        { sqsQueueName = Just cmvQueueName+        , sqsQuery =+            [ ("Action", Just "ChangeMessageVisibility")+            , ("ReceiptHandle", Just . TE.encodeUtf8 $ printReceiptHandle cmvReceiptHandle)+            , ("VisibilityTimeout", Just . B.pack $ show cmvVisibilityTimeout)+            ]+        }  instance Transaction ChangeMessageVisibility ChangeMessageVisibilityResponse
Aws/Sqs/Core.hs view
@@ -188,7 +188,7 @@       expandedQuery = sortBy (comparing fst)                         ( sqsQuery ++ [ ("AWSAccessKeyId", Just(accessKeyID signatureCredentials)),                         ("Expires", Just(BC.pack expiresString)), -                       ("SignatureMethod", Just("HmacSHA256")), ("SignatureVersion",Just("2")), ("Version",Just("2009-02-01"))+                       ("SignatureMethod", Just("HmacSHA256")), ("SignatureVersion",Just("2")), ("Version",Just("2012-11-05"))                         ])       @@ -254,7 +254,7 @@ data QueueName = QueueName{   qName :: T.Text,   qAccountNumber :: T.Text-} deriving(Show)+} deriving(Show, Read, Eq, Ord)  printQueueName :: QueueName -> T.Text printQueueName queue = T.concat ["/", (qAccountNumber queue), "/", (qName queue), "/"]@@ -274,11 +274,18 @@  data MessageAttribute     = MessageAll+    -- ^ all values     | SenderId+    -- ^ the AWS account number (or the IP address, if anonymous access is+    -- allowed) of the sender     | SentTimestamp+    -- ^ the time when the message was sent (epoch time in milliseconds)     | ApproximateReceiveCount+    -- ^ the number of times a message has been received but not deleted     | ApproximateFirstReceiveTimestamp-    deriving(Show,Eq,Enum)+    -- ^ the time when the message was first received (epoch time in+    -- milliseconds)+    deriving(Show,Read,Eq,Ord,Enum,Bounded)  data SqsPermission     = PermissionAll@@ -335,8 +342,8 @@ printPermission PermissionChangeMessageVisibility = "ChangeMessageVisibility" printPermission PermissionGetQueueAttributes = "GetQueueAttributes" -newtype ReceiptHandle = ReceiptHandle T.Text deriving(Show,Eq)-newtype MessageId = MessageId T.Text deriving(Show,Eq)+newtype ReceiptHandle = ReceiptHandle T.Text deriving(Show, Read, Eq, Ord)+newtype MessageId = MessageId T.Text deriving(Show, Read, Eq, Ord)  printReceiptHandle :: ReceiptHandle -> T.Text printReceiptHandle (ReceiptHandle handle) = handle
+ Examples/DynamoDb.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++-------------------------------------------------------------------------------+import           Aws+import           Aws.DynamoDb.Commands+import           Aws.DynamoDb.Core+import           Control.Concurrent+import           Control.Monad+import           Control.Monad.Catch+import           Data.Conduit+import qualified Data.Conduit.List     as C+import qualified Data.Text             as T+import           Network.HTTP.Conduit  (withManager)+-------------------------------------------------------------------------------++createTableAndWait :: IO ()+createTableAndWait = do+  let req0 = createTable "devel-1"+        [AttributeDefinition "name" AttrString]+        (HashOnly "name")+        (ProvisionedThroughput 1 1)+  resp0 <- runCommand req0+  print resp0++  print "Waiting for table to be created"+  threadDelay (30 * 1000000)++  let req1 = DescribeTable "devel-1"+  resp1 <- runCommand req1+  print resp1++main :: IO ()+main = do+  cfg <- Aws.baseConfiguration++  createTableAndWait `catch` (\DdbError{} -> putStrLn "Table already exists")++  putStrLn "Putting an item..."++  let x = item [ attrAs text "name" "josh"+               , attrAs text "class" "not-so-awesome"]++  let req1 = (putItem "devel-1" x ) { piReturn = URAllOld+                                    , piRetCons =  RCTotal+                                    , piRetMet = RICMSize+                                    }+++  resp1 <- runCommand req1+  print resp1++  putStrLn "Getting the item back..."++  let req2 = getItem "devel-1" (hk "name" "josh")+  resp2 <- runCommand req2+  print resp2++  print =<< runCommand+    (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesome")])++  echo "Updating with false conditional."+  (print =<< runCommand+    (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer")])+      { uiExpect = Conditions CondAnd [Condition "name" (DEq "john")] })+    `catch` (\ (e :: DdbError) -> echo ("Eating exception: " ++ show e))++  echo "Getting the item back..."+  print =<< runCommand req2+++  echo "Updating with true conditional"+  print =<< runCommand+    (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer")])+      { uiExpect = Conditions CondAnd [Condition "name" (DEq "josh")] }++  echo "Getting the item back..."+  print =<< runCommand req2++  echo "Running a Query command..."+  print =<< runCommand (query "devel-1" (Slice (Attribute "name" "josh") Nothing))++  echo "Running a Scan command..."+  print =<< runCommand (scan "devel-1")++  echo "Filling table with several items..."+  forM_ [0..30] $ \ i -> do+    threadDelay 50000+    runCommand $ putItem "devel-1" $+      item [Attribute "name" (toValue $ T.pack ("lots-" ++ show i)), attrAs int "val" i]++  echo "Now paginating in increments of 5..."+  let q0 = (scan "devel-1") { sLimit = Just 5 }++  xs <- withManager $ \mgr -> do+    awsIteratedList cfg debugServiceConfig mgr q0 $$ C.consume+  echo ("Pagination returned " ++ show (length xs) ++ " items")+++runCommand r = do+    cfg <- Aws.baseConfiguration+    Aws.simpleAws cfg debugServiceConfig r++echo = putStrLn++
Examples/Sqs.hs view
@@ -3,12 +3,17 @@ import qualified Aws import qualified Aws.Core import qualified Aws.Sqs as Sqs+import Control.Concurrent+import Control.Error+import Control.Monad.IO.Class+import Data.Monoid+import Data.String import qualified Data.Text.IO as T import qualified Data.Text    as T import qualified Data.Text.Read as TR import Control.Monad (forM_, forM, replicateM) -{-| Created by Tim Perry on September 18, 2013 +{-| Created by Tim Perry on September 18, 2013   |   | All code relies on a correctly configured ~/.aws-keys and will access that account which   | may incur charges for the user!@@ -26,12 +31,12 @@ main = do   {- Set up AWS credentials and the default configuration. -}   cfg <- Aws.baseConfiguration-  let sqscfg = Sqs.sqs Aws.Core.HTTPS Sqs.sqsEndpointUsWest2 False :: Sqs.SqsConfiguration Aws.NormalQuery+  let sqscfg = Sqs.sqs Aws.Core.HTTP Sqs.sqsEndpointUsWest2 False :: Sqs.SqsConfiguration Aws.NormalQuery    {- List any Queues you have already created in your SQS account -}   Sqs.ListQueuesResponse qUrls <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing   let origQUrlCount = length qUrls-  putStrLn $ "originally had " ++ (show origQUrlCount) ++ " queue urls"+  putStrLn $ "originally had " ++ show origQUrlCount ++ " queue urls"   mapM_ print qUrls    {- Create a request object to create a queue and then print out the Queue URL -}@@ -41,7 +46,7 @@   T.putStrLn $ T.concat ["queue was created with Url: ", qUrl]    {- Create a QueueName object, sqsQName, to hold the name of this queue for the duration -}-  let awsAccountNum = (T.split (== '/') qUrl) !! 3+  let awsAccountNum = T.split (== '/') qUrl !! 3   let sqsQName = Sqs.QueueName qName awsAccountNum    {- list queue attributes -- for this example we will only list the approximateNumberOfMessages in this queue. -}@@ -50,39 +55,60 @@   mapM_ (\(attName, attText) -> T.putStrLn $ T.concat ["     ", Sqs.printQueueAttribute attName, " ", attText]) attPairs    {- Here we add some messages to the queue -}-  let messages = map (\n -> T.pack $ "msg" ++ (show n)) [1 .. 10]+  let messages = map (\n -> T.pack $ "msg" ++ show n) [1 .. 10]   {- Add messages to the queue -}-  forM_ messages (\mText -> do-      T.putStrLn $ T.concat ["   Adding: ", mText]-      let sqsSendMessage = Sqs.SendMessage mText sqsQName-      Aws.simpleAws cfg sqscfg sqsSendMessage)+  forM_ messages $ \mText -> do+      T.putStrLn $ "   Adding: " <> mText+      let sqsSendMessage = Sqs.SendMessage mText sqsQName [] (Just 0)+      Sqs.SendMessageResponse _ mid _ <- Aws.simpleAws cfg sqscfg sqsSendMessage+      T.putStrLn $ "      message id: " <> sshow mid    {- Here we remove messages from the queue one at a time. -}-  let receiveMessageReq = Sqs.ReceiveMessage Nothing [] (Just 1) sqsQName+  let receiveMessageReq = Sqs.ReceiveMessage Nothing [] (Just 1) [] sqsQName (Just 20)   let numMessages = length messages   removedMsgs <- replicateM numMessages $ do-      Sqs.ReceiveMessageResponse msgs <- Aws.simpleAws cfg sqscfg receiveMessageReq+      msgs <- eitherT (const $ return []) return . retryT 2 $ do+        Sqs.ReceiveMessageResponse r <- liftIO $ Aws.simpleAws cfg sqscfg receiveMessageReq+        case r of+          [] -> left "no message received"+          _ -> right r+      putStrLn $ "number of messages received: " ++ show (length msgs)       forM msgs (\msg -> do-                     -- here we remove a message, delete it from the queue, and then return the +                     -- here we remove a message, delete it from the queue, and then return the                      -- text sent in the body of the message-                     putStrLn $ "Received " ++ (show $ Sqs.mBody msg)+                     putStrLn $ "   Received " ++ show (Sqs.mBody msg)                      Aws.simpleAws cfg sqscfg $ Sqs.DeleteMessage (Sqs.mReceiptHandle msg) sqsQName                      return $ Sqs.mBody msg)    {- Now we'll delete the queue we created at the start of this program -}-  putStrLn $ "Deleting the queue: " ++ (show $ Sqs.qName sqsQName)+  putStrLn $ "Deleting the queue: " ++ show (Sqs.qName sqsQName)   let dQReq = Sqs.DeleteQueue sqsQName   _ <- Aws.simpleAws cfg sqscfg dQReq    {- | Let's make sure the queue was actually deleted and that the same number of queues exist at when      | the program ends as when it started.   -}-  putStrLn $ "Listing all queueus to check to see if " ++ (show $ Sqs.qName sqsQName) ++ " is gone"-  Sqs.ListQueuesResponse qUrls <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing-  mapM_ T.putStrLn qUrls+  eitherT T.putStrLn T.putStrLn . retryT 4 $ do+    qUrls <- liftIO $ do+      putStrLn $ "Listing all queueus to check to see if " ++ show (Sqs.qName sqsQName) ++ " is gone"+      Sqs.ListQueuesResponse qUrls_ <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing+      mapM_ T.putStrLn qUrls_+      return qUrls_ -  if qUrl `elem` qUrls-     then putStrLn $ " *\n *\n * Warning, '" ++ (show qName) ++ "' was not deleted\n"-                  ++ " * This is probably just a race condition."-     else putStrLn $ "     The queue '" ++ (show qName) ++ "' was correctly deleted"+    if qUrl `elem` qUrls+        then left $ " *\n *\n * Warning, '" <> sshow qName <> "' was not deleted\n"+                    <> " * This is probably just a race condition."+        else right $ "     The queue '" <> sshow qName <> "' was correctly deleted"++retryT :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m a+retryT i f = go 1+  where+    go x+        | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f+        | otherwise = f `catchT` \_ -> do+            liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))+            go (succ x)++sshow :: (Show a, IsString b) => a -> b+sshow = fromString . show
README.org view
@@ -88,13 +88,20 @@  * Release Notes -** 0.9 series+** 0.10 series -- 0.9.4-  - allow http-types 0.9+- 0.10+  - [EXPERIMENTAL!] DynamoDB: support for creating/updating/querying and scanning items+  - SQS: complete overhaul to support 2012-11-05 features+  - SQS: test suite+  - S3: use Maybe for 404 HEAD requests on objects instead of throwing a misleading exception+  - S3: support of poAutoMakeBucket for Internet Archive users+  - S3: implement GetBucketLocation+  - S3: add South American region+  - S3: allow specifying the Content-Type when copying objects+  - core: fix typo in NoCredentialsException accessor -- 0.9.4-  - allow conduit 1.2+** 0.9 series  - 0.9.3   - fix performance regression for loadCredentialsDefault@@ -252,7 +259,7 @@ | David Vollbracht   | [[https://github.com/qxjit][qxjit]]        |                           |                        |               | | Felipe Lessa       | [[https://github.com/meteficha][meteficha]]    | felipe.lessa@gmail.com    | currently secret       | Core, S3, SES | | Nathan Howell      | [[https://github.com/NathanHowell][NathanHowell]] | nhowell@alphaheavy.com    | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3            |-| Ozgun Ataman       | [[https://github.com/ozataman][ozataman]]     | ozgun.ataman@soostone.com | [[http://soostone.com][Soostone Inc]]           | Core, S3      |+| Ozgun Ataman       | [[https://github.com/ozataman][ozataman]]     | ozgun.ataman@soostone.com | [[http://soostone.com][Soostone Inc]]           | Core, S3, DynamoDb | | Steve Severance    | [[https://github.com/sseveran][sseveran]]     | sseverance@alphaheavy.com | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3, SQS       | | John Wiegley       | [[https://github.com/jwiegley][jwiegley]]     | johnw@fpcomplete.com      | [[http://fpcomplete.com][FP Complete]]            | Co-Maintainer, S3            | | Chris Dornan | [[https://github.com/cdornan][cdornan]] | chris.dornan@irisconnect.co.uk | [[http://irisconnect.co.uk][Iris Connect]] | Core |
aws.cabal view
@@ -1,5 +1,5 @@ Name:                aws-Version:             0.9.5+Version:             0.10 Synopsis:            Amazon Web Services (AWS) for Haskell Description:         Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at <https://github.com/aristidb/aws/blob/master/README.org>. Homepage:            http://github.com/aristidb/aws@@ -20,7 +20,7 @@ Source-repository this   type: git   location: https://github.com/aristidb/aws.git-  tag: 0.9.5+  tag: 0.10  Source-repository head   type: git@@ -32,84 +32,93 @@  Library   Exposed-modules:-                       Aws,-                       Aws.Aws,-                       Aws.Core,-                       Aws.Ec2.InstanceMetadata,-                       Aws.Iam,-                       Aws.Iam.Commands,-                       Aws.Iam.Commands.CreateAccessKey,-                       Aws.Iam.Commands.CreateUser,-                       Aws.Iam.Commands.DeleteAccessKey,-                       Aws.Iam.Commands.DeleteUser,-                       Aws.Iam.Commands.DeleteUserPolicy,-                       Aws.Iam.Commands.GetUser,-                       Aws.Iam.Commands.GetUserPolicy,-                       Aws.Iam.Commands.ListAccessKeys,-                       Aws.Iam.Commands.ListUserPolicies,-                       Aws.Iam.Commands.ListUsers,-                       Aws.Iam.Commands.PutUserPolicy,-                       Aws.Iam.Commands.UpdateAccessKey,-                       Aws.Iam.Commands.UpdateUser,-                       Aws.Iam.Core,-                       Aws.Iam.Internal,-                       Aws.S3,-                       Aws.S3.Commands,-                       Aws.S3.Commands.CopyObject,-                       Aws.S3.Commands.DeleteBucket,-                       Aws.S3.Commands.DeleteObject,-                       Aws.S3.Commands.DeleteObjects,-                       Aws.S3.Commands.GetBucket,-                       Aws.S3.Commands.GetObject,-                       Aws.S3.Commands.GetService,-                       Aws.S3.Commands.HeadObject,-                       Aws.S3.Commands.PutBucket,-                       Aws.S3.Commands.PutObject,-                       Aws.S3.Core,-                       Aws.SimpleDb,-                       Aws.SimpleDb.Commands,-                       Aws.SimpleDb.Commands.Attributes,-                       Aws.SimpleDb.Commands.Domain,-                       Aws.SimpleDb.Commands.Select,-                       Aws.SimpleDb.Core,-                       Aws.Sqs,-                       Aws.Sqs.Commands,-                       Aws.Sqs.Commands.Permission,-                       Aws.Sqs.Commands.Message,-                       Aws.Sqs.Commands.Queue,-                       Aws.Sqs.Commands.QueueAttributes,-                       Aws.Sqs.Core,-                       Aws.Ses,-                       Aws.Ses.Commands,-                       Aws.Ses.Commands.SendRawEmail,-                       Aws.Ses.Commands.ListIdentities,-                       Aws.Ses.Commands.VerifyEmailIdentity,-                       Aws.Ses.Commands.VerifyDomainIdentity,-                       Aws.Ses.Commands.VerifyDomainDkim,-                       Aws.Ses.Commands.DeleteIdentity,-                       Aws.Ses.Commands.GetIdentityDkimAttributes,-                       Aws.Ses.Commands.GetIdentityNotificationAttributes,-                       Aws.Ses.Commands.GetIdentityVerificationAttributes,-                       Aws.Ses.Commands.SetIdentityNotificationTopic,-                       Aws.Ses.Commands.SetIdentityDkimEnabled,-                       Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled,-                       Aws.Ses.Core,-                       Aws.DynamoDb.Commands,-                       Aws.DynamoDb.Commands.Table,-                       Aws.DynamoDb.Core,+                       Aws+                       Aws.Aws+                       Aws.Core+                       Aws.DynamoDb+                       Aws.DynamoDb.Commands+                       Aws.DynamoDb.Commands.GetItem+                       Aws.DynamoDb.Commands.PutItem+                       Aws.DynamoDb.Commands.Query+                       Aws.DynamoDb.Commands.Scan+                       Aws.DynamoDb.Commands.Table+                       Aws.DynamoDb.Commands.UpdateItem+                       Aws.DynamoDb.Core+                       Aws.Ec2.InstanceMetadata+                       Aws.Iam+                       Aws.Iam.Commands+                       Aws.Iam.Commands.CreateAccessKey+                       Aws.Iam.Commands.CreateUser+                       Aws.Iam.Commands.DeleteAccessKey+                       Aws.Iam.Commands.DeleteUser+                       Aws.Iam.Commands.DeleteUserPolicy+                       Aws.Iam.Commands.GetUser+                       Aws.Iam.Commands.GetUserPolicy+                       Aws.Iam.Commands.ListAccessKeys+                       Aws.Iam.Commands.ListUserPolicies+                       Aws.Iam.Commands.ListUsers+                       Aws.Iam.Commands.PutUserPolicy+                       Aws.Iam.Commands.UpdateAccessKey+                       Aws.Iam.Commands.UpdateUser+                       Aws.Iam.Core+                       Aws.Iam.Internal                        Aws.Network+                       Aws.S3+                       Aws.S3.Commands+                       Aws.S3.Commands.CopyObject+                       Aws.S3.Commands.DeleteBucket+                       Aws.S3.Commands.DeleteObject+                       Aws.S3.Commands.DeleteObjects+                       Aws.S3.Commands.GetBucket+                       Aws.S3.Commands.GetBucketLocation+                       Aws.S3.Commands.GetObject+                       Aws.S3.Commands.GetService+                       Aws.S3.Commands.HeadObject+                       Aws.S3.Commands.PutBucket+                       Aws.S3.Commands.PutObject+                       Aws.S3.Core+                       Aws.Ses+                       Aws.Ses.Commands+                       Aws.Ses.Commands.DeleteIdentity+                       Aws.Ses.Commands.GetIdentityDkimAttributes+                       Aws.Ses.Commands.GetIdentityNotificationAttributes+                       Aws.Ses.Commands.GetIdentityVerificationAttributes+                       Aws.Ses.Commands.ListIdentities+                       Aws.Ses.Commands.SendRawEmail+                       Aws.Ses.Commands.SetIdentityDkimEnabled+                       Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled+                       Aws.Ses.Commands.SetIdentityNotificationTopic+                       Aws.Ses.Commands.VerifyDomainDkim+                       Aws.Ses.Commands.VerifyDomainIdentity+                       Aws.Ses.Commands.VerifyEmailIdentity+                       Aws.Ses.Core+                       Aws.SimpleDb+                       Aws.SimpleDb.Commands+                       Aws.SimpleDb.Commands.Attributes+                       Aws.SimpleDb.Commands.Domain+                       Aws.SimpleDb.Commands.Select+                       Aws.SimpleDb.Core+                       Aws.Sqs+                       Aws.Sqs.Commands+                       Aws.Sqs.Commands.Message+                       Aws.Sqs.Commands.Permission+                       Aws.Sqs.Commands.Queue+                       Aws.Sqs.Commands.QueueAttributes+                       Aws.Sqs.Core    Build-depends:                        aeson                >= 0.6,+                       attoparsec           >= 0.11    && < 0.13,                        base                 == 4.*,                        base16-bytestring    == 0.1.*,+                       base16-bytestring    == 0.1.*,                        base64-bytestring    == 1.0.*,                        blaze-builder        >= 0.2.1.4 && < 0.4,                        byteable             == 0.1.*,                        bytestring           >= 0.9     && < 0.11,                        case-insensitive     >= 0.2     && < 1.3,                        cereal               >= 0.3     && < 0.5,-                       conduit              >= 1.1     && < 1.3,+                       conduit              >= 1.1     && < 1.2,                        conduit-extra        >= 1.1     && < 1.2,                        containers           >= 0.4,                        cryptohash           >= 0.11     && < 0.12,@@ -117,21 +126,24 @@                        directory            >= 1.0     && < 1.3,                        filepath             >= 1.1     && < 1.4,                        http-conduit         >= 2.1     && < 2.2,-                       http-types           >= 0.7     && < 0.10,+                       http-types           >= 0.7     && < 0.9,                        lifted-base          >= 0.1     && < 0.3,                        monad-control        >= 0.3,                        mtl                  == 2.*,                        network              == 2.*,                        old-locale           == 1.*,                        resourcet            >= 1.1     && < 1.2,+                       safe                 >= 0.3     && < 0.4,+                       scientific           >= 0.3,+                       tagged               >= 0.7     && < 0.8,                        text                 >= 0.11,                        time                 >= 1.1.4   && < 1.5,-                       transformers         >= 0.2.2 && < 0.5,+                       transformers         >= 0.2.2   && < 0.5,                        unordered-containers >= 0.2,                        utf8-string          == 0.3.*,                        vector               >= 0.10,-                       xml-conduit          >= 1.2 && <1.3-+                       xml-conduit          >= 1.2     && <1.3+    if !impl(ghc >= 7.6)     Build-depends: ghc-prim @@ -204,6 +216,26 @@    Default-Language: Haskell2010 +Executable DynamoDb+  Main-is: DynamoDb.hs+  Hs-source-dirs: Examples++  if !flag(Examples)+    Buildable: False+  else+    Buildable: True+    Build-depends:+                       aws,+                       base == 4.*,+                       data-default,+                       exceptions,+                       http-conduit,+                       text,+                       conduit++  Default-Language: Haskell2010++ Executable Sqs   Main-is: Sqs.hs   Hs-source-dirs: Examples@@ -215,6 +247,35 @@     Build-depends:                        base == 4.*,                        aws,-                       text >=0.11+                       errors >= 1.4,+                       text >=0.11,+                       transformers >= 0.3    Default-Language: Haskell2010++test-suite sqs-tests+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    hs-source-dirs: tests+    main-is: Sqs/Main.hs++    other-modules:+        Utils++    build-depends:+        QuickCheck >= 2.7,+        aeson >= 0.7,+        aws,+        base == 4.*,+        bytestring >= 0.10,+        errors >= 1.4.7,+        mtl >= 2.1,+        quickcheck-instances >= 0.3,+        tagged >= 0.7,+        tasty >= 0.8,+        tasty-quickcheck >= 0.8,+        text >= 1.1,+        transformers >= 0.3++    ghc-options: -Wall -threaded+
+ tests/Sqs/Main.hs view
@@ -0,0 +1,316 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Haskell SQS bindings+--++module Main+( main+) where++import Aws+import Aws.Core+import qualified Aws.Sqs as SQS++import Control.Arrow (second)+import Control.Error+import Control.Monad+import Control.Monad.IO.Class++import qualified Data.List as L+import Data.Monoid+import qualified Data.Text as T++import Test.Tasty+import Test.QuickCheck.Instances ()++import System.Environment+import System.Exit++import Utils++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = do+    args <- getArgs+    runMain args $ map (second tail . span (/= '=')) args+  where+    runMain :: [String] -> [(String,String)] -> IO ()+    runMain args _argsMap+        | any (`elem` helpArgs) args = defaultMain tests+        | "--run-with-aws-credentials" `elem` args =+            withArgs (tastyArgs args) . defaultMain $ tests+        | otherwise = putStrLn help >> exitFailure++    helpArgs = ["--help", "-h"]+    mainArgs =+        [ "--run-with-aws-credentials"+        ]+    tastyArgs args = flip filter args $ \x -> not+        $ any (`L.isPrefixOf` x) mainArgs+++help :: String+help = L.intercalate "\n"+    [ ""+    , "NOTE"+    , ""+    , "This test suite accesses the AWS account that is associated with"+    , "the default credentials from the credential file ~/.aws-keys."+    , ""+    , "By running the tests in this test-suite costs for usage of AWS"+    , "services may incur."+    , ""+    , "In order to actually excute the tests in this test-suite you must"+    , "provide the command line options:"+    , ""+    , "    --run-with-aws-credentials"+    , ""+    , "When running this test-suite through cabal you may use the following"+    , "command:"+    , ""+    , "    cabal test sqs-tests --test-option=--run-with-aws-credentials"+    , ""+    ]++tests :: TestTree+tests = testGroup "SQS Tests"+    [ test_queue+    , test_message+    ]++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--+-- TODO make these configurable++testProtocol :: Protocol+testProtocol = HTTP++testSqsEndpoint :: SQS.Endpoint+testSqsEndpoint = SQS.sqsEndpointUsWest2++defaultQueueName :: T.Text+defaultQueueName = "test-queue"++-- -------------------------------------------------------------------------- --+-- SQS Utils++sqsQueueName :: T.Text -> SQS.QueueName+sqsQueueName url = SQS.QueueName (sqsQueueNameText url) (sqsAccountIdText url)++sqsQueueNameText :: T.Text -> T.Text+sqsQueueNameText url = T.split (== '/') url !! 4++sqsAccountIdText :: T.Text -> T.Text+sqsAccountIdText url = T.split (== '/') url !! 3++sqsConfiguration :: SQS.SqsConfiguration qt+sqsConfiguration = SQS.SqsConfiguration+    { SQS.sqsProtocol = testProtocol+    , SQS.sqsEndpoint = testSqsEndpoint+    , SQS.sqsPort = 80+    , SQS.sqsUseUri = False+    , SQS.sqsDefaultExpiry = 180+    }++simpleSqs+    :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)+    => r+    -> m (MemoryResponse a)+simpleSqs command = do+    c <- baseConfiguration+    simpleAws c sqsConfiguration command++simpleSqsT+    :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)+    => r+    -> EitherT T.Text m (MemoryResponse a)+simpleSqsT = tryT . simpleSqs++withQueueTest+    :: T.Text -- ^ Queue name+    -> (IO (T.Text, SQS.QueueName) -> TestTree) -- ^ test tree+    -> TestTree+withQueueTest queueName f = withResource createQueue deleteQueue $ \getQueueUrl ->+    f $ do+        url <- getQueueUrl+        return (url, sqsQueueName url)+  where+    createQueue = do+        SQS.CreateQueueResponse url <- simpleSqs $ SQS.CreateQueue Nothing queueName+        return url+    deleteQueue url = void $ simpleSqs (SQS.DeleteQueue (sqsQueueName url))++-- -------------------------------------------------------------------------- --+-- Queue Tests++test_queue :: TestTree+test_queue = testGroup "Queue Tests"+    [ eitherTOnceTest1 "CreateListDeleteQueue" prop_createListDeleteQueue+    ]++-- |+--+prop_createListDeleteQueue+    :: T.Text -- ^ queue name+    -> EitherT T.Text IO ()+prop_createListDeleteQueue queueName = do+    SQS.CreateQueueResponse queueUrl <- simpleSqsT $ SQS.CreateQueue Nothing tQueueName+    let queue = sqsQueueName queueUrl+    handleT (\e -> deleteQueue queue >> left e) $ do+        retryT 6 $ do+            SQS.ListQueuesResponse allQueueUrls <- simpleSqsT (SQS.ListQueues Nothing)+            unless (queueUrl `elem` allQueueUrls)+                . left $ "queue " <> sshow queueUrl <> " not listed"+        deleteQueue queue+  where+    tQueueName = testData queueName+    deleteQueue queueUrl = void $ simpleSqsT (SQS.DeleteQueue queueUrl)++-- -------------------------------------------------------------------------- --+-- Message Tests++test_message :: TestTree+test_message =+    withQueueTest defaultQueueName $ \getQueueParams -> testGroup "Queue Tests"+        [ eitherTOnceTest0 "SendReceiveDeleteMessage" $ do+            (_, queue) <- liftIO getQueueParams+            prop_sendReceiveDeleteMessage queue+        , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling" $ do+            (_, queue) <- liftIO getQueueParams+            prop_sendReceiveDeleteMessageLongPolling queue+        , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling1" $ do+            (_, queue) <- liftIO getQueueParams+            prop_sendReceiveDeleteMessageLongPolling1 queue+        ]++-- | Simple send and short-polling receive. First sends all messages+-- and receives messages thereafter one by one.+--+prop_sendReceiveDeleteMessage+    :: SQS.QueueName+    -> EitherT T.Text IO ()+prop_sendReceiveDeleteMessage queue = do++    -- a visibility timeout should be used only if either @receiveBatch == 1@+    -- or no retry is used so that all received messages are handled.+    let visTimeout = Just 60+    let delay = Just 0+    let poll = Nothing -- no consistent receive (any number of messages up to the requested number can be returned)+    let receiveBatch = 1+    let msgNum = 10++    let messages = map (\i -> "message" <> sshow i) [1 .. msgNum]++    -- send messages+    forM_ messages $ \msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay++    recMsgs <- fmap concat . replicateM msgNum $ do+        msgs <- retryT 5 $ do+            r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll+            case r of+                SQS.ReceiveMessageResponse [] -> left "no message received"+                SQS.ReceiveMessageResponse t+                    | length t <= receiveBatch -> right t+                    | otherwise -> left $ "unexpected number of messages received: " <> sshow (length t)+        forM_ msgs $ \msg -> retryT 5 $+            simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue+        return (map SQS.mBody msgs)++    let recv = L.sort recMsgs+    let sent = L.sort messages+    unless (sent == recv)+        $ left $ "received messages don't match send messages; sent: "+            <> sshow sent <> "; got: " <> sshow recv++-- | Checks for consistent receive: There is no message delay, so all messages+-- are available when the first receive is requested. By enabling long-polling+-- (with value 0) we force SQS to do a consistent receive.+--+prop_sendReceiveDeleteMessageLongPolling+    :: SQS.QueueName+    -> EitherT T.Text IO ()+prop_sendReceiveDeleteMessageLongPolling queue = do++    let delay = Nothing+    let visTimeout = Just 60+    let poll = Just 1 -- consistent receive (maximum available number of requested messages is returned)+    let receiveBatch = 10+    let msgNum = 40 -- this must be a multiple of 'receiveBatch'++    let messages = map (\i -> "message" <> sshow i) [1 .. msgNum]++    -- send messages+    forM_ messages $ \msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay++    recMsgs <- fmap concat . replicateM (msgNum `div` receiveBatch) $ do+        msgs <- do+            r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll+            case r of+                SQS.ReceiveMessageResponse [] -> left "no messages received"+                SQS.ReceiveMessageResponse t+                    | length t == receiveBatch -> right t+                    | otherwise -> left $ "unexpected number of messages received: " <> sshow (length t)+        forM_ msgs $ \msg -> retryT 5 $+            simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue+        return (map SQS.mBody msgs)++    let recv = L.sort recMsgs+    let sent = L.sort messages+    unless (sent == recv)+        $ left $ "received messages don't match send messages; sent: "+            <> sshow sent <> "; got: " <> sshow recv++-- | Checks that long polling is actually enabled. We add a delay to the messages+-- and immediately make a receive request with a polling wait time that is larger+-- than the delay. Note that even though polling forces consistent reads, messages+-- will become available with some (small) offset. Therefor we request only a single+-- message at a time.+--+prop_sendReceiveDeleteMessageLongPolling1+    :: SQS.QueueName+    -> EitherT T.Text IO ()+prop_sendReceiveDeleteMessageLongPolling1 queue = do++    let delay = Just 2+    let visTimeout = Just 60+    let poll = Just 5 -- consistent receive (maximum available number of requested messages is returned)+    let receiveBatch = 1+    let msgNum = 10 -- this must be a multiple of 'receiveBatch'++    let messages = map (\i -> "message" <> sshow i) [1 :: Int .. msgNum]++    recMsgs <- fmap concat . forM messages $ \msg -> do+        void . simpleSqsT $ SQS.SendMessage msg queue [] delay+        msgs <- do+            r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll+            case r of+                SQS.ReceiveMessageResponse [] -> left "no messages received"+                SQS.ReceiveMessageResponse t+                    | length t == receiveBatch -> right t+                    | otherwise -> left $ "unexpected number of messages received: " <> sshow (length t)+        forM_ msgs $ \m -> retryT 5 $+            simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle m) queue+        return (map SQS.mBody msgs)++    let recv = L.sort recMsgs+    let sent = L.sort messages+    unless (sent == recv)+        $ left $ "received messages don't match send messages; sent: "+            <> sshow sent <> "; got: " <> sshow recv
+ tests/Utils.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}++-- |+-- Module: Utils+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Utils for Tests for Haskell AWS bindints+--+module Utils+(+-- * Parameters+  testDataPrefix++-- * General Utils+, sshow+, tryT+, retryT+, testData++, evalTestT+, evalTestTM+, eitherTOnceTest0+, eitherTOnceTest1+, eitherTOnceTest2++-- * Generic Tests+, test_jsonRoundtrip+, prop_jsonRoundtrip+) where++import Control.Concurrent (threadDelay)+import Control.Error+import Control.Monad+import Control.Monad.Identity+import Control.Monad.IO.Class++import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)+import Data.Monoid+import Data.Proxy+import Data.String+import qualified Data.Text as T+import Data.Typeable++import Test.QuickCheck.Property+import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--++-- | This prefix is used for the IDs and names of all entities that are+-- created in the AWS account.+--+testDataPrefix :: IsString a => a+testDataPrefix = "__TEST_AWSHASKELLBINDINGS__"++-- -------------------------------------------------------------------------- --+-- General Utils++tryT :: MonadIO m => IO a -> EitherT T.Text m a+tryT = fmapLT (T.pack . show) . syncIO++testData :: (IsString a, Monoid a) => a -> a+testData a = testDataPrefix <> a++retryT :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m a+retryT i f = go 1+  where+    go x+        | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f+        | otherwise = f `catchT` \_ -> do+            liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))+            go (succ x)++sshow :: (Show a, IsString b) => a -> b+sshow = fromString . show++evalTestTM+    :: Functor f+    => String -- ^ test name+    -> f (EitherT T.Text IO a) -- ^ test+    -> f (PropertyM IO Bool)+evalTestTM name = fmap $+    (liftIO . runEitherT) >=> \r -> case r of+        Left e ->+            fail $ "failed to run test \"" <> name <> "\": " <> show e+        Right _ -> return True++evalTestT+    :: String -- ^ test name+    -> EitherT T.Text IO a -- ^ test+    -> PropertyM IO Bool+evalTestT name = runIdentity . evalTestTM name . Identity++eitherTOnceTest0+    :: String -- ^ test name+    -> EitherT T.Text IO a -- ^ test+    -> TestTree+eitherTOnceTest0 name test = testProperty name . once . monadicIO+    $ evalTestT name test++eitherTOnceTest1+    :: (Arbitrary a, Show a)+    => String -- ^ test name+    -> (a -> EitherT T.Text IO b)+    -> TestTree+eitherTOnceTest1 name test = testProperty name . once $ monadicIO+    . evalTestTM name test++eitherTOnceTest2+    :: (Arbitrary a, Show a, Arbitrary b, Show b)+    => String -- ^ test name+    -> (a -> b -> EitherT T.Text IO c)+    -> TestTree+eitherTOnceTest2 name test = testProperty name . once $ \a b -> monadicIO+    $ (evalTestTM name $ uncurry test) (a, b)++-- -------------------------------------------------------------------------- --+-- Generic Tests++test_jsonRoundtrip+    :: forall a . (Eq a, Show a, FromJSON a, ToJSON a, Typeable a, Arbitrary a)+    => Proxy a+    -> TestTree+test_jsonRoundtrip proxy = testProperty msg (prop_jsonRoundtrip :: a -> Property)+  where+    msg = "JSON roundtrip for " <> show typ+#if MIN_VERSION_base(4,7,0)+    typ = typeRep proxy+#else+    typ = typeOf (undefined :: a)+#endif++prop_jsonRoundtrip :: forall a . (Eq a, Show a, FromJSON a, ToJSON a) => a -> Property+prop_jsonRoundtrip a = either (const $ property False) (\(b :: [a]) -> [a] === b) $+    eitherDecode $ encode [a]+