diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -82,6 +82,7 @@ , credentials :: Credentials -- | The error / message logger. , logger :: Logger + , proxy :: Maybe HTTP.Proxy } -- | The default configuration, with credentials loaded from environment variable or configuration file @@ -95,6 +96,7 @@ timeInfo = Timestamp , credentials = cr' , logger = defaultLog Warning + , proxy = Nothing } -- | Debug configuration, which logs much more verbosely. @@ -234,7 +236,9 @@ let !q = {-# SCC "unsafeAwsRef:signQuery" #-} signQuery request info sd let logDebug = liftIO . logger cfg Debug . T.pack logDebug $ "String to sign: " ++ show (sqStringToSign q) - !httpRequest <- {-# SCC "unsafeAwsRef:httpRequest" #-} liftIO $ queryToHttpRequest q + !httpRequest <- {-# SCC "unsafeAwsRef:httpRequest" #-} liftIO $ do + req <- queryToHttpRequest q + return $ req { HTTP.proxy = proxy cfg } logDebug $ "Host: " ++ show (HTTP.host httpRequest) logDebug $ "Path: " ++ show (HTTP.path httpRequest) logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest) 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,7 @@ module Aws.DynamoDb.Commands - ( module Aws.DynamoDb.Commands.DeleteItem + ( module Aws.DynamoDb.Commands.BatchGetItem + , module Aws.DynamoDb.Commands.BatchWriteItem + , module Aws.DynamoDb.Commands.DeleteItem , module Aws.DynamoDb.Commands.GetItem , module Aws.DynamoDb.Commands.PutItem , module Aws.DynamoDb.Commands.Query @@ -9,6 +11,8 @@ ) where ------------------------------------------------------------------------------- +import Aws.DynamoDb.Commands.BatchGetItem +import Aws.DynamoDb.Commands.BatchWriteItem import Aws.DynamoDb.Commands.DeleteItem import Aws.DynamoDb.Commands.GetItem import Aws.DynamoDb.Commands.PutItem diff --git a/Aws/DynamoDb/Commands/BatchGetItem.hs b/Aws/DynamoDb/Commands/BatchGetItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/BatchGetItem.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.BatchGetItem +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Justin Dawson +-- Stability : experimental +-- +-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_BatchGetItem.html@ +---------------------------------------------------------------------------- + +module Aws.DynamoDb.Commands.BatchGetItem where + +------------------------------------------------------------------------------- +import Control.Applicative +import Data.Aeson +import Data.Default +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Prelude +------------------------------------------------------------------------------- +import Aws.Core +import Aws.DynamoDb.Core +import Aws.DynamoDb.Commands.GetItem +------------------------------------------------------------------------------- + + +data GetRequestItem = GetRequestItem{ + griProjExpr :: Maybe T.Text + , griConsistent ::Bool + , griKeys :: [PrimaryKey] + } deriving (Eq,Show,Read,Ord) + +data BatchGetItem = BatchGetItem { + bgRequests :: [(T.Text,GetRequestItem)] + -- ^ Get Requests for a specified table + , bgRetCons :: ReturnConsumption + } deriving (Eq,Show,Read,Ord) + +------------------------------------------------------------------------------- + +-- | Construct a RequestItem . +batchGetRequestItem :: Maybe T.Text + -- ^ Projection Expression + -> Bool + -- ^ Consistent Read + -> [PrimaryKey] + -- ^ Items to be deleted + -> GetRequestItem +batchGetRequestItem expr consistent keys = GetRequestItem expr consistent keys + +toBatchGet :: [GetItem] -> BatchGetItem +toBatchGet gs = BatchGetItem (convert gs) def + + where + groupItems :: [GetItem]-> HM.HashMap T.Text [GetItem] -> HM.HashMap T.Text [GetItem] + groupItems [] hm = hm + groupItems (x:xs) hm = let key = giTableName x + in groupItems xs (HM.insert key (x : (HM.lookupDefault [] key hm)) hm) + + convert :: [GetItem] -> [(T.Text,GetRequestItem)] + convert gs' = let l = HM.toList $ groupItems gs' HM.empty + -- Uses one GetItem to specify ProjectionExpression + -- and ConsistentRead for the entire batch + in map (\(table,items@(i:_)) ->(table,GetRequestItem + (T.intercalate "," <$> giAttrs i) + (giConsistent i) + (map giKey items)) ) l + +-- | Construct a BatchGetItem +batchGetItem :: [(T.Text, GetRequestItem)] + -> BatchGetItem +batchGetItem reqs = BatchGetItem reqs def + + +instance ToJSON GetRequestItem where + toJSON GetRequestItem{..} = + (object $ maybe [] (return . ("ProjectionExpression" .=)) griProjExpr ++ + ["ConsistentRead" .= griConsistent + , "Keys" .= griKeys]) + + +instance ToJSON BatchGetItem where + toJSON BatchGetItem{..} = + object $ + [ "RequestItems" .= HM.fromList bgRequests + , "ReturnConsumedCapacity" .= bgRetCons + ] + +instance FromJSON GetRequestItem where + parseJSON (Object p) = do + GetRequestItem <$> p .:? "ProjectionExpression" + <*> p .: "ConsistentRead" + <*> p .: "Keys" + parseJSON _ = fail "unable to parse GetRequestItem" + + +data BatchGetItemResponse = BatchGetItemResponse { + bgResponses :: [(T.Text, [Item])] + , bgUnprocessed :: Maybe [(T.Text,GetRequestItem)] + -- ^ Unprocessed Requests on failure + , bgConsumed :: Maybe ConsumedCapacity + -- ^ Amount of capacity consumed + } deriving (Eq,Show,Read,Ord) + + + +instance Transaction BatchGetItem BatchGetItemResponse + + +instance SignQuery BatchGetItem where + type ServiceConfiguration BatchGetItem = DdbConfiguration + signQuery gi = ddbSignQuery "BatchGetItem" gi + + +instance FromJSON BatchGetItemResponse where + parseJSON (Object v) = BatchGetItemResponse + <$> (HM.toList <$> (v .: "Responses")) + <*> v .:? "UnprocessedItems" + <*> v .:? "ConsumedCapacity" + + parseJSON _ = fail "BatchGetItemResponse must be an object." + +instance ResponseConsumer r BatchGetItemResponse where + type ResponseMetadata BatchGetItemResponse = DdbResponse + responseConsumer _ _ ref resp = ddbResponseConsumer ref resp + +instance AsMemoryResponse BatchGetItemResponse where + type MemoryResponse BatchGetItemResponse = BatchGetItemResponse + loadToMemory = return + + diff --git a/Aws/DynamoDb/Commands/BatchWriteItem.hs b/Aws/DynamoDb/Commands/BatchWriteItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/BatchWriteItem.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.BatchWriteItem +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Justin Dawson +-- Stability : experimental +-- +-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_BatchWriteItem.html@ +---------------------------------------------------------------------------- + +module Aws.DynamoDb.Commands.BatchWriteItem where + +------------------------------------------------------------------------------- +import Control.Applicative +import Data.Aeson +import Data.Default +import Data.Foldable (asum) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Prelude +------------------------------------------------------------------------------- +import Aws.Core +import Aws.DynamoDb.Core +import Aws.DynamoDb.Commands.PutItem +import Aws.DynamoDb.Commands.DeleteItem +------------------------------------------------------------------------------- + + +data Request = PutRequest { prItem :: Item } + | DeleteRequest {drKey :: PrimaryKey} + deriving (Eq,Show,Read,Ord) + +data BatchWriteItem = BatchWriteItem { + bwRequests :: [(T.Text,[Request])] + -- ^ Put or Delete Requests for a specified table + , bwRetCons :: ReturnConsumption + , bwRetMet :: ReturnItemCollectionMetrics + } deriving (Eq,Show,Read,Ord) + + +------------------------------------------------------------------------------- + +toBatchWrite :: [PutItem] + -> [DeleteItem] + -> BatchWriteItem +toBatchWrite ps ds =BatchWriteItem maps def def + where + maps :: [(T.Text,[Request])] + maps = let pMap = foldl (\acc p -> let key = piTable p + in HM.insert key (PutRequest (piItem p) : (HM.lookupDefault [] key acc)) acc) HM.empty ps + totalMap = foldl (\acc d -> let key = diTable d + in HM.insert key (DeleteRequest (diKey d) : (HM.lookupDefault [] key acc)) acc) pMap ds + in HM.toList totalMap +-- | Construct a BatchWriteItem +batchWriteItem :: [(T.Text,[Request])] + -> BatchWriteItem +batchWriteItem reqs = BatchWriteItem reqs def def + + +instance ToJSON Request where + toJSON PutRequest{..} = + object $ + [ "PutRequest" .= (object $ ["Item" .= prItem]) + ] + toJSON DeleteRequest{..} = + object $ + [ "DeleteRequest" .= (object $ ["Key" .= drKey]) + ] + +instance ToJSON BatchWriteItem where + toJSON BatchWriteItem{..} = + object $ + [ "RequestItems" .= HM.fromList bwRequests + , "ReturnConsumedCapacity" .= bwRetCons + , "ReturnItemCollectionMetrics" .= bwRetMet + ] + +instance FromJSON Request where + parseJSON = withObject "PutRequest or DeleteRequest" $ \o -> + + asum [ + do + pr <- o .: "PutRequest" + i <- pr .: "Item" + return $ PutRequest i , + do + dr <- o .: "DeleteRequest" + pk <- dr .: "Key" + return $ DeleteRequest pk + ] + +data BatchWriteItemResponse = BatchWriteItemResponse { + bwUnprocessed :: [(T.Text,[Request])] + -- ^ Unprocessed Requests on failure + , bwConsumed :: Maybe ConsumedCapacity + -- ^ Amount of capacity consumed + , bwColMet :: Maybe ItemCollectionMetrics + -- ^ Collection metrics for tables affected by BatchWriteItem. + } deriving (Eq,Show,Read,Ord) + + + +instance Transaction BatchWriteItem BatchWriteItemResponse + + +instance SignQuery BatchWriteItem where + type ServiceConfiguration BatchWriteItem = DdbConfiguration + signQuery gi = ddbSignQuery "BatchWriteItem" gi + + +instance FromJSON BatchWriteItemResponse where + parseJSON (Object v) = BatchWriteItemResponse + <$> HM.toList <$> (v .: "UnprocessedItems") + <*> v .:? "ConsumedCapacity" + <*> v .:? "ItemCollectionMetrics" + parseJSON _ = fail "BatchWriteItemResponse must be an object." + + +instance ResponseConsumer r BatchWriteItemResponse where + type ResponseMetadata BatchWriteItemResponse = DdbResponse + responseConsumer _ _ ref resp = ddbResponseConsumer ref resp + + +instance AsMemoryResponse BatchWriteItemResponse where + type MemoryResponse BatchWriteItemResponse = BatchWriteItemResponse + loadToMemory = return 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 @@ -38,6 +38,7 @@ import qualified Data.Aeson.Types as A import Data.Char (toUpper) import qualified Data.HashMap.Strict as M +import Data.Scientific (Scientific) import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX @@ -63,6 +64,10 @@ dropOpt d = A.defaultOptions { A.fieldLabelModifier = drop d } +convertToUTCTime :: Scientific -> UTCTime +convertToUTCTime = posixSecondsToUTCTime . fromInteger . round + + -- | 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 @@ -211,8 +216,8 @@ instance A.FromJSON ProvisionedThroughputStatus where parseJSON = A.withObject "Throughput status must be an object" $ \o -> ProvisionedThroughputStatus - <$> (posixSecondsToUTCTime . fromInteger <$> o .:? "LastDecreaseDateTime" .!= 0) - <*> (posixSecondsToUTCTime . fromInteger <$> o .:? "LastIncreaseDateTime" .!= 0) + <$> (convertToUTCTime <$> o .:? "LastDecreaseDateTime" .!= 0) + <*> (convertToUTCTime <$> o .:? "LastIncreaseDateTime" .!= 0) <*> o .:? "NumberOfDecreasesToday" .!= 0 <*> o .: "ReadCapacityUnits" <*> o .: "WriteCapacityUnits" @@ -283,7 +288,7 @@ TableDescription <$> t .: "TableName" <*> t .: "TableSizeBytes" <*> t .: "TableStatus" - <*> (fmap (posixSecondsToUTCTime . fromInteger) <$> t .:? "CreationDateTime") + <*> (fmap convertToUTCTime <$> t .:? "CreationDateTime") <*> t .: "ItemCount" <*> t .:? "AttributeDefinitions" .!= [] <*> t .:? "KeySchema" diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -532,6 +532,15 @@ Object p2 = toJSON r in Object (p1 `HM.union` p2) +instance FromJSON PrimaryKey where + parseJSON p = do + l <- listPKey p + case length l of + 1 -> return $ head l + _ -> fail "Unable to parse PrimaryKey" + where listPKey p'= map (\(txt,dval)-> hk txt dval) + . HM.toList <$> parseJSON p' + -- | A key-value pair data Attribute = Attribute { 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 @@ -133,9 +133,9 @@ 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 ) + [ ( pre <> "Name", Just $ TE.encodeUtf8 name ) + , ( pre <> "Value.DataType", Just typ ) + , ( pre <> "Value." <> valueKey, Just encodedValue ) ] where pre = "MessageAttribute." <> B.pack (show i) <> "." @@ -488,22 +488,22 @@ -> Response SqsMetadata UserMessageAttributeValue readUserMessageAttributeValue cursor = do typStr <- force "Missing DataType" - $ cursor $/ Cu.laxElement "DataType" &/ Cu.content + $ cursor $// Cu.laxElement "DataType" &/ Cu.content case parseType typStr of ("String", c) -> do val <- force "Missing StringValue" - $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content + $ cursor $// Cu.laxElement "StringValue" &/ Cu.content return $ UserMessageAttributeString c val ("Number", c) -> do valStr <- force "Missing StringValue" - $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content + $ 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 + val64 <- force "Missing BinaryValue" + $ cursor $// Cu.laxElement "BinaryValue" &/ Cu.content val <- tryXml . B64.decode $ TE.encodeUtf8 val64 return $ UserMessageAttributeBinary c val diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.17 series +----------- + +- 0.17 + - HTTP proxy support + - DDB: Support for additional interfaces, bug fixes + - Relax version bounds + 0.16 series ----------- diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -1,5 +1,5 @@ Name: aws -Version: 0.16 +Version: 0.17 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 @@ -19,7 +19,7 @@ Source-repository this type: git location: https://github.com/aristidb/aws.git - tag: 0.16 + tag: 0.17 Source-repository head type: git @@ -36,6 +36,8 @@ Aws.Core Aws.DynamoDb Aws.DynamoDb.Commands + Aws.DynamoDb.Commands.BatchGetItem + Aws.DynamoDb.Commands.BatchWriteItem Aws.DynamoDb.Commands.DeleteItem Aws.DynamoDb.Commands.GetItem Aws.DynamoDb.Commands.PutItem @@ -140,12 +142,12 @@ scientific >= 0.3, tagged >= 0.7 && < 0.9, text >= 0.11, - time >= 1.4.0 && < 1.7, + time >= 1.4.0 && < 2.0, transformers >= 0.2.2 && < 0.6, unordered-containers >= 0.2, utf8-string >= 0.3 && < 1.1, vector >= 0.10, - xml-conduit >= 1.2 && <1.5 + xml-conduit >= 1.2 && <2.0 if !impl(ghc >= 7.6) Build-depends: ghc-prim @@ -345,7 +347,7 @@ base == 4.*, bytestring >= 0.10, errors >= 2.0, - http-client >= 0.3 && < 0.5, + http-client >= 0.3 && < 0.6, lifted-base >= 0.2, monad-control >= 0.3, mtl >= 2.1, @@ -407,7 +409,7 @@ base == 4.*, bytestring, conduit-combinators, - http-client < 0.5, + http-client < 0.6, http-client-tls < 0.5, http-types, resourcet, diff --git a/tests/S3/Main.hs b/tests/S3/Main.hs --- a/tests/S3/Main.hs +++ b/tests/S3/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} @@ -30,6 +31,10 @@ import Network.HTTP.Client (HttpException (..), RequestBody (..), newManager, responseBody) +#if MIN_VERSION_http_client(0, 5, 0) +import Network.HTTP.Client (HttpExceptionContent (..), + responseStatus) +#endif import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status import System.Environment @@ -271,7 +276,13 @@ Right _ -> assertFailure ("Expected error with status " <> show expectedStatus <> ", but got success.") Left _ -> return () where +#if MIN_VERSION_http_client(0, 5, 0) + selector (HttpExceptionRequest _ (StatusCodeException res _)) + | statusCode (responseStatus res) == expectedStatus = Just () + selector _ = Nothing +#else selector (StatusCodeException s _ _) | statusCode s == expectedStatus = Just () | otherwise = Nothing selector _ = Nothing +#endif