diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -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 diff --git a/Aws/DynamoDb.hs b/Aws/DynamoDb.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynaboDb +-- Copyright : Ozgun Ataman, Soostone Inc. +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- Stability : experimental +-- +---------------------------------------------------------------------------- + +module Aws.DynamoDb + ( module Aws.DynamoDb.Core + , module Aws.DynamoDb.Commands + ) where + +------------------------------------------------------------------------------- +import Aws.DynamoDb.Commands +import Aws.DynamoDb.Core +------------------------------------------------------------------------------- diff --git a/Aws/DynamoDb/Commands.hs b/Aws/DynamoDb/Commands.hs --- a/Aws/DynamoDb/Commands.hs +++ b/Aws/DynamoDb/Commands.hs @@ -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 +------------------------------------------------------------------------------- diff --git a/Aws/DynamoDb/Commands/GetItem.hs b/Aws/DynamoDb/Commands/GetItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/GetItem.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.GetItem +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- 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 diff --git a/Aws/DynamoDb/Commands/PutItem.hs b/Aws/DynamoDb/Commands/PutItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/PutItem.hs @@ -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 +-- 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 + + + + + + + + diff --git a/Aws/DynamoDb/Commands/Query.hs b/Aws/DynamoDb/Commands/Query.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/Query.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.Query +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- 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)) diff --git a/Aws/DynamoDb/Commands/Scan.hs b/Aws/DynamoDb/Commands/Scan.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/Scan.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.Scan +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- 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 } diff --git a/Aws/DynamoDb/Commands/Table.hs b/Aws/DynamoDb/Commands/Table.hs --- a/Aws/DynamoDb/Commands/Table.hs +++ b/Aws/DynamoDb/Commands/Table.hs @@ -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 diff --git a/Aws/DynamoDb/Commands/UpdateItem.hs b/Aws/DynamoDb/Commands/UpdateItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/UpdateItem.hs @@ -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 +-- 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 + + + + + + + + diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -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 "" rid `mappend` + ", x-amz-id-2=" `mappend` + fromMaybe "" 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 + + diff --git a/Aws/S3/Commands.hs b/Aws/S3/Commands.hs --- a/Aws/S3/Commands.hs +++ b/Aws/S3/Commands.hs @@ -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 diff --git a/Aws/S3/Commands/CopyObject.hs b/Aws/S3/Commands/CopyObject.hs --- a/Aws/S3/Commands/CopyObject.hs +++ b/Aws/S3/Commands/CopyObject.hs @@ -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 diff --git a/Aws/S3/Commands/GetBucketLocation.hs b/Aws/S3/Commands/GetBucketLocation.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/GetBucketLocation.hs @@ -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 diff --git a/Aws/S3/Commands/HeadObject.hs b/Aws/S3/Commands/HeadObject.hs --- a/Aws/S3/Commands/HeadObject.hs +++ b/Aws/S3/Commands/HeadObject.hs @@ -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 diff --git a/Aws/S3/Commands/PutObject.hs b/Aws/S3/Commands/PutObject.hs --- a/Aws/S3/Commands/PutObject.hs +++ b/Aws/S3/Commands/PutObject.hs @@ -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 diff --git a/Aws/S3/Core.hs b/Aws/S3/Core.hs --- a/Aws/S3/Core.hs +++ b/Aws/S3/Core.hs @@ -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 diff --git a/Aws/Sqs/Commands/Message.hs b/Aws/Sqs/Commands/Message.hs --- a/Aws/Sqs/Commands/Message.hs +++ b/Aws/Sqs/Commands/Message.hs @@ -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. +-- +-- +-- +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). +-- +-- +-- +-- /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 +-- 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] +-- +-- +-- +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 +-- +-- all fields of @SendMessageResult@ are denoted as optional. +-- At +-- +-- 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 . + + , 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 . + } + 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. +-- +-- +-- +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 +-- +-- 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 +-- . +-- +-- * 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. +-- +-- +-- +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 +-- +-- all elements are denoted as optional. +-- In +-- +-- 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 . + + , 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. +-- +-- +-- +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 diff --git a/Aws/Sqs/Core.hs b/Aws/Sqs/Core.hs --- a/Aws/Sqs/Core.hs +++ b/Aws/Sqs/Core.hs @@ -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 diff --git a/Examples/DynamoDb.hs b/Examples/DynamoDb.hs new file mode 100644 --- /dev/null +++ b/Examples/DynamoDb.hs @@ -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 + + diff --git a/Examples/Sqs.hs b/Examples/Sqs.hs --- a/Examples/Sqs.hs +++ b/Examples/Sqs.hs @@ -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 diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -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 | diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -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 . 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 + diff --git a/tests/Sqs/Main.hs b/tests/Sqs/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Sqs/Main.hs @@ -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 +-- 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 diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -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 +-- 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] +