aws 0.8.4 → 0.8.5
raw patch · 9 files changed
+717/−22 lines, 9 filesdep +aesondep +attoparsec-conduitdep +base16-bytestringdep ~basedep ~case-insensitive
Dependencies added: aeson, attoparsec-conduit, base16-bytestring, unordered-containers, vector
Dependency ranges changed: base, case-insensitive
Files
- Aws/Aws.hs +1/−1
- Aws/Core.hs +103/−11
- Aws/DynamoDb/Commands.hs +5/−0
- Aws/DynamoDb/Commands/Table.hs +432/−0
- Aws/DynamoDb/Core.hs +129/−0
- Aws/S3/Commands/PutObject.hs +3/−1
- Aws/S3/Core.hs +25/−5
- README.org +7/−0
- aws.cabal +12/−4
Aws/Aws.hs view
@@ -213,7 +213,7 @@ sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg let q = signQuery request info sd liftIO $ logger cfg Debug $ T.pack $ "String to sign: " ++ show (sqStringToSign q)- let httpRequest = queryToHttpRequest q+ httpRequest <- liftIO $ queryToHttpRequest q liftIO $ logger cfg Debug $ T.pack $ "Host: " ++ show (HTTP.host httpRequest) resp <- do hresp <- HTTP.http httpRequest manager
Aws/Core.hs view
@@ -49,6 +49,7 @@ , AuthorizationHash(..) , amzHash , signature+, authorizationV4 -- ** Query construction helpers , queryList , awsBool@@ -93,10 +94,11 @@ import Control.Monad.IO.Class import qualified Crypto.Classes as Crypto import qualified Crypto.HMAC as HMAC-import Crypto.Hash.CryptoAPI (MD5, SHA1, SHA256)+import Crypto.Hash.CryptoAPI (MD5, SHA1, SHA256, hash') import Data.Attempt (Attempt(..), FromAttempt(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Lazy as L@@ -217,6 +219,9 @@ class Transaction r a => IteratedTransaction r a | r -> a , a -> r where nextIteratedRequest :: r -> a -> Maybe r +-- | Signature version 4: ((region, service),(date,key))+type V4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString))+ -- | AWS access credentials. data Credentials = Credentials {@@ -224,8 +229,11 @@ accessKeyID :: B.ByteString -- | AWS Secret Access Key. , secretAccessKey :: B.ByteString+ -- | Signing keys for signature version 4+ , v4SigningKeys :: IORef [V4Key] }- deriving (Show)+instance Show Credentials where+ show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ "}" -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'. --@@ -247,9 +255,13 @@ loadCredentialsFromFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromFile file key = liftIO $ do contents <- map T.words . T.lines <$> T.readFile file+ ref <- newIORef [] return $ do [_key, keyID, secret] <- find (hasKey key) contents- return Credentials { accessKeyID = T.encodeUtf8 keyID, secretAccessKey = T.encodeUtf8 secret }+ return Credentials { accessKeyID = T.encodeUtf8 keyID+ , secretAccessKey = T.encodeUtf8 secret+ , v4SigningKeys = ref+ } where hasKey _ [] = False hasKey k (k2 : _) = k == k2@@ -259,10 +271,13 @@ loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do env <- getEnvironment+ ref <- newIORef [] let lk = flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY"- return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret))+ return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) + <*> (T.encodeUtf8 . T.pack <$> secret)+ <*> return ref) -- | Load credentials from environment variables if possible, or alternatively from a file with a given key name. --@@ -335,8 +350,8 @@ , sqQuery :: HTTP.Query -- | Request date/time. , sqDate :: Maybe UTCTime- -- | Authorization string (if applicable), for @Authorization@ header..- , sqAuthorization :: Maybe B.ByteString+ -- | Authorization string (if applicable), for @Authorization@ header. See 'authorizationV4'+ , sqAuthorization :: Maybe (IO B.ByteString) -- | Request body content type. , sqContentType :: Maybe B.ByteString -- | Request body content MD5.@@ -358,12 +373,13 @@ -- | Create a HTTP request from a 'SignedQuery' object. #if MIN_VERSION_http_conduit(2, 0, 0)-queryToHttpRequest :: SignedQuery -> HTTP.Request+queryToHttpRequest :: SignedQuery -> IO HTTP.Request #else-queryToHttpRequest :: SignedQuery -> HTTP.Request (C.ResourceT IO)+queryToHttpRequest :: SignedQuery -> IO (HTTP.Request (C.ResourceT IO)) #endif-queryToHttpRequest SignedQuery{..}- = def {+queryToHttpRequest SignedQuery{..} = do+ mauth <- maybe (return Nothing) (Just<$>) sqAuthorization+ return $ def { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False@@ -375,7 +391,7 @@ , HTTP.requestHeaders = catMaybes [ checkDate (\d -> ("Date", fmtRfc822Time d)) sqDate , fmap (\c -> ("Content-Type", c)) contentType , fmap (\md5 -> ("Content-MD5", Base64.encode $ Serialize.encode md5)) sqContentMd5- , fmap (\auth -> ("Authorization", auth)) sqAuthorization]+ , fmap (\auth -> ("Authorization", auth)) mauth] ++ sqAmzHeaders ++ sqOtherHeaders , HTTP.requestBody = case sqMethod of@@ -487,6 +503,82 @@ computeSig t = Serialize.encode (HMAC.hmac' key input `asTypeOf` t) key :: HMAC.MacKey c d key = HMAC.MacKey (secretAccessKey cr)++-- | Use this to create the Authorization header to set into 'sqAuthorization'.+-- See <http://docs.aws.amazon.com/general/latest/gr/signature-version-4.html>: you must create the+-- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3.+authorizationV4 :: SignatureData+ -> AuthorizationHash + -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target+ -> B.ByteString -- ^ canonicalRequest (before hashing)+ -> IO B.ByteString+authorizationV4 sd ah region service headers canonicalRequest = do+ let ref = v4SigningKeys $ signatureCredentials sd+ date = fmtTime "%Y%m%d" $ signatureTime sd+ hmac k i = case ah of+ HmacSHA1 -> Serialize.encode (HMAC.hmac' (HMAC.MacKey k) i :: SHA1)+ HmacSHA256 -> Serialize.encode (HMAC.hmac' (HMAC.MacKey k) i :: SHA256)+ hash i = case ah of+ HmacSHA1 -> Serialize.encode (hash' i :: SHA1)+ HmacSHA256 -> Serialize.encode (hash' i :: SHA256)+ alg = case ah of+ HmacSHA1 -> "AWS4-HMAC-SHA1"+ HmacSHA256 -> "AWS4-HMAC-SHA256"++ -- Lookup existing signing key+ allkeys <- readIORef ref+ let mkey = case lookup (region,service) allkeys of+ Just (d,k) | d /= date -> Nothing+ | otherwise -> Just k+ Nothing -> Nothing++ -- possibly create a new signing key+ key <- case mkey of+ Just k -> return k+ Nothing -> atomicModifyIORef ref $ \keylist ->+ let secretKey = secretAccessKey $ signatureCredentials sd+ kDate = hmac ("AWS4" <> secretKey) date+ kRegion = hmac kDate region+ kService = hmac kRegion service+ kSigning = hmac kService "aws4_request"+ lstK = (region,service)+ keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist+ in (keylist', kSigning)++ -- now do the signature+ let canonicalRequestHash = Base16.encode $ hash canonicalRequest+ stringToSign = B.concat [ alg+ , "\n"+ , fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd+ , "\n"+ , date+ , "/"+ , region+ , "/"+ , service+ , "/aws4_request\n"+ , canonicalRequestHash+ ]+ sig = Base16.encode $ hmac key stringToSign++ -- finally, return the header+ return $ B.concat [ alg+ , " Credential="+ , accessKeyID (signatureCredentials sd)+ , "/"+ , date+ , "/"+ , region+ , "/"+ , service+ , "/aws4_request,"+ , "SignedHeaders="+ , headers+ , ",Signature="+ , sig+ ] -- | Default configuration for a specific service. class DefaultServiceConfiguration config where
+ Aws/DynamoDb/Commands.hs view
@@ -0,0 +1,5 @@+module Aws.DynamoDb.Commands(+ module Aws.DynamoDb.Commands.Table+) where++import Aws.DynamoDb.Commands.Table
+ Aws/DynamoDb/Commands/Table.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}+module Aws.DynamoDb.Commands.Table(+ -- * Commands+ CreateTable(..)+ , CreateTableResult(..)+ , DescribeTable(..)+ , DescribeTableResult(..)+ , UpdateTable(..)+ , UpdateTableResult(..)+ , DeleteTable(..)+ , DeleteTableResult(..)+ , ListTables(..)+ , ListTablesResult(..)++ -- * Data passed in the commands+ , KeyAttributeType(..)+ , KeyAttributeDefinition(..)+ , KeySchema(..)+ , Projection(..)+ , LocalSecondaryIndex(..)+ , LocalSecondaryIndexStatus(..)+ , ProvisionedThroughput(..)+ , ProvisionedThroughputStatus(..)+ , GlobalSecondaryIndex(..)+ , GlobalSecondaryIndexStatus(..)+ , GlobalSecondaryIndexUpdate(..)+ , TableDescription(..)+) where++import Aws.Core+import Aws.DynamoDb.Core+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.Time+import Data.Time.Clock.POSIX+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as M+import GHC.Generics (Generic)++capitalizeOpt :: A.Options+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+ parseJSON (A.String str) =+ case str of+ "S" -> return AttrStringT+ "N" -> return AttrNumberT+ "B" -> return AttrBinaryT+ _ -> 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+ toJSON = A.genericToJSON capitalizeOpt+instance A.FromJSON KeyAttributeDefinition 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)+instance A.ToJSON KeySchema where+ toJSON (KeyHashOnly attr) + = A.Array $ V.fromList [ A.object [ "AttributeName" .= attr+ , "KeyType" .= ("HASH" :: T.Text)+ ]+ ]+ toJSON (KeyHashAndRange hash range) + = A.Array $ V.fromList [ A.object [ "AttributeName" .= hash+ , "KeyType" .= ("HASH" :: T.Text)+ ]+ , A.object [ "AttributeName" .= range+ , "KeyType" .= ("RANGE" :: T.Text)+ ]+ ]+instance A.FromJSON KeySchema where+ parseJSON (A.Array v) =+ case V.length v of+ 1 -> do obj <- A.parseJSON (v V.! 0)+ kt <- obj .: "KeyType"+ if kt /= ("HASH" :: T.Text)+ then fail "With only one key, the type must be HASH"+ else KeyHashOnly <$> obj .: "AttributeName"++ 2 -> do hash <- A.parseJSON (v V.! 0)+ range <- A.parseJSON (v V.! 1)+ hkt <- hash .: "KeyType"+ 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"+ _ -> fail "Key schema must have one or two entries"+ parseJSON _ = fail "Key schema must be an array"++-- | This determines which attributes are projected into a secondary index.+data Projection = ProjectKeysOnly+ | ProjectAll+ | ProjectInclude [T.Text]+ deriving Show+instance A.ToJSON Projection where+ toJSON ProjectKeysOnly = A.object [ "ProjectionType" .= ("KEYS_ONLY" :: T.Text) ]+ toJSON ProjectAll = A.object [ "ProjectionType" .= ("ALL" :: T.Text) ]+ toJSON (ProjectInclude a) = A.object [ "ProjectionType" .= ("INCLUDE" :: T.Text)+ , "NonKeyAttributes" .= a+ ]+instance A.FromJSON Projection where+ parseJSON (A.Object o) = do+ ty <- (o .: "ProjectionType") :: A.Parser T.Text+ case ty of+ "KEYS_ONLY" -> return ProjectKeysOnly+ "ALL" -> return ProjectAll+ "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.+data LocalSecondaryIndex+ = LocalSecondaryIndex {+ localIndexName :: T.Text+ , localKeySchema :: KeySchema+ , localProjection :: Projection+ }+ deriving (Show, Generic)+instance A.ToJSON LocalSecondaryIndex where+ toJSON = A.genericToJSON $ dropOpt 5+instance A.FromJSON LocalSecondaryIndex where+ parseJSON = A.genericParseJSON $ dropOpt 5++-- | This is returned by AWS to describe the local secondary index.+data LocalSecondaryIndexStatus+ = LocalSecondaryIndexStatus {+ locStatusIndexName :: T.Text+ , locStatusIndexSizeBytes :: Integer+ , locStatusItemCount :: Integer+ , locStatusKeySchema :: KeySchema+ , locStatusProjection :: Projection+ }+ deriving (Show, Generic)+instance A.FromJSON LocalSecondaryIndexStatus where+ parseJSON = A.genericParseJSON $ dropOpt 9++-- | The target provisioned throughput you are requesting for the table or global secondary index.+data ProvisionedThroughput+ = ProvisionedThroughput {+ readCapacityUnits :: Int+ , writeCapacityUnits :: Int+ }+ deriving (Show, Generic)+instance A.ToJSON ProvisionedThroughput where+ toJSON = A.genericToJSON capitalizeOpt+instance A.FromJSON ProvisionedThroughput where+ parseJSON = A.genericParseJSON capitalizeOpt++-- | 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+ , statusNumberOfDecreasesToday :: Int+ , statusReadCapacityUnits :: Int+ , statusWriteCapacityUnits :: Int+ }+ deriving (Show, Generic)+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)+ <*> o .:? "NumberOfDecreasesToday" .!= 0+ <*> o .: "ReadCapacityUnits"+ <*> o .: "WriteCapacityUnits"++-- | Describes a global secondary index.+data GlobalSecondaryIndex+ = GlobalSecondaryIndex {+ globalIndexName :: T.Text+ , globalKeySchema :: KeySchema+ , globalProjection :: Projection+ , globalProvisionedThroughput :: ProvisionedThroughput+ }+ deriving (Show, Generic)+instance A.ToJSON GlobalSecondaryIndex where+ toJSON = A.genericToJSON $ dropOpt 6+instance A.FromJSON GlobalSecondaryIndex where+ parseJSON = A.genericParseJSON $ dropOpt 6++-- | 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+ , 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.+data GlobalSecondaryIndexUpdate+ = GlobalSecondaryIndexUpdate {+ 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.+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]+ , 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+ (Just (A.Object t), _) -> return t+ (_, Just (A.Object t)) -> return t+ _ -> fail "Table description must have key 'Table' or 'TableDescription'"+ TableDescription <$> t .: "TableName"+ <*> t .: "TableSizeBytes"+ <*> t .: "TableStatus"+ <*> (posixSecondsToUTCTime . fromInteger <$> t .: "CreationDateTime")+ <*> t .: "ItemCount"+ <*> t .: "AttributeDefinitions"+ <*> t .: "KeySchema"+ <*> 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+instance AsMemoryResponse TableDescription where+ type MemoryResponse TableDescription = TableDescription+ loadToMemory = return+-}++-------------------------------------------------------------------------------+--- 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)+instance A.ToJSON CreateTable where+ toJSON ct = A.object $ m ++ lindex ++ gindex+ where+ m = [ "TableName" .= createTableName ct+ , "AttributeDefinitions" .= createAttributeDefinitions ct+ , "KeySchema" .= createKeySchema ct+ , "ProvisionedThroughput" .= createProvisionedThroughput ct+ ]+ -- AWS will error with 500 if (LocalSecondaryIndexes : []) is present in the JSON+ lindex = if null (createLocalSecondaryIndexes ct)+ then []+ else [ "LocalSecondaryIndexes" .= createLocalSecondaryIndexes ct ]+ gindex = if null (createGlobalSecondaryIndexes ct)+ then []+ else [ "GlobalSecondaryIndexes" .= createGlobalSecondaryIndexes ct ]+--instance A.ToJSON CreateTable where+-- toJSON = A.genericToJSON $ dropOpt 6+ +-- | ServiceConfiguration: 'DyConfiguration'+instance SignQuery CreateTable where+ type ServiceConfiguration CreateTable = DyConfiguration+ signQuery = dySignQuery "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+instance AsMemoryResponse CreateTableResult where+ type MemoryResponse CreateTableResult = TableDescription+ loadToMemory = return . ctStatus++instance Transaction CreateTable CreateTableResult++data DescribeTable+ = DescribeTable {+ dTableName :: T.Text + }+ deriving (Show, Generic)+instance A.ToJSON DescribeTable where+ toJSON = A.genericToJSON $ dropOpt 1++-- | ServiceConfiguration: 'DyConfiguration'+instance SignQuery DescribeTable where+ type ServiceConfiguration DescribeTable = DyConfiguration+ signQuery = dySignQuery "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+instance AsMemoryResponse DescribeTableResult where+ type MemoryResponse DescribeTableResult = TableDescription+ loadToMemory = return . dtStatus++instance Transaction DescribeTable DescribeTableResult++data UpdateTable+ = UpdateTable {+ updateTableName :: T.Text+ , updateProvisionedThroughput :: ProvisionedThroughput+ , updateGlobalSecondaryIndexUpdates :: [GlobalSecondaryIndexUpdate]+ }+ deriving (Show, Generic)+instance A.ToJSON UpdateTable where+ toJSON = A.genericToJSON $ dropOpt 6+ +-- | ServiceConfiguration: 'DyConfiguration'+instance SignQuery UpdateTable where+ type ServiceConfiguration UpdateTable = DyConfiguration+ signQuery = dySignQuery "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+instance AsMemoryResponse UpdateTableResult where+ type MemoryResponse UpdateTableResult = TableDescription+ loadToMemory = return . uStatus++instance Transaction UpdateTable UpdateTableResult++data DeleteTable+ = DeleteTable {+ deleteTableName :: T.Text+ }+ deriving (Show, Generic)+instance A.ToJSON DeleteTable where+ toJSON = A.genericToJSON $ dropOpt 6++-- | ServiceConfiguration: 'DyConfiguration'+instance SignQuery DeleteTable where+ type ServiceConfiguration DeleteTable = DyConfiguration+ signQuery = dySignQuery "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+instance AsMemoryResponse DeleteTableResult where+ type MemoryResponse DeleteTableResult = TableDescription+ loadToMemory = return . dStatus++instance Transaction DeleteTable DeleteTableResult++-- | TODO: currently this does not support restarting a cutoff query because of size.+data ListTables = ListTables+ deriving (Show)+instance A.ToJSON ListTables where+ toJSON _ = A.object []+-- | ServiceConfiguration: 'DyConfiguration'+instance SignQuery ListTables where+ type ServiceConfiguration ListTables = DyConfiguration+ signQuery = dySignQuery "ListTables"++newtype ListTablesResult+ = ListTablesResult {+ 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+instance AsMemoryResponse ListTablesResult where+ type MemoryResponse ListTablesResult = [T.Text] + loadToMemory = return . tableNames++instance Transaction ListTables ListTablesResult
+ Aws/DynamoDb/Core.hs view
@@ -0,0 +1,129 @@+module Aws.DynamoDb.Core where++import Aws.Core+import qualified Control.Exception as C+import Crypto.Hash.CryptoAPI (SHA256, hash)+import qualified Data.Aeson as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Lazy as BL+import Data.Conduit+import qualified Data.Conduit.Attoparsec as Atto+import Data.Monoid+import Data.Typeable+import qualified Data.Serialize as Serialize+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++ hash256 :: BL.ByteString -> SHA256+ hash256 = hash++ bodyLBS = A.encode body+ bodyHash = Base16.encode $ Serialize.encode $ hash256 bodyLBS++ 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 -> monadThrow $ DyError (HTTP.responseStatus resp) "" err+ _ -> monadThrow $ DyError (HTTP.responseStatus resp) "" (show val)
Aws/S3/Commands/PutObject.hs view
@@ -28,6 +28,7 @@ poAcl :: Maybe CannedAcl, poStorageClass :: Maybe StorageClass, poWebsiteRedirectLocation :: Maybe T.Text,+ poServerSideEncryption :: Maybe ServerSideEncryption, #if MIN_VERSION_http_conduit(2, 0, 0) poRequestBody :: HTTP.RequestBody, #else@@ -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 body []+putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] data PutObjectResponse = PutObjectResponse {@@ -63,6 +64,7 @@ ("x-amz-acl",) <$> writeCannedAcl <$> poAcl , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass , ("x-amz-website-redirect-location",) <$> poWebsiteRedirectLocation+ , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> poServerSideEncryption ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [ ("Expires",) . T.pack . show <$> poExpires
Aws/S3/Core.hs view
@@ -51,6 +51,7 @@ , s3Endpoint :: B.ByteString , s3RequestStyle :: RequestStyle , s3Port :: Int+ , s3ServerSideEncryption :: Maybe ServerSideEncryption , s3UseUri :: Bool , s3DefaultExpiry :: NominalDiffTime }@@ -80,6 +81,9 @@ s3EndpointApSouthEast :: B.ByteString s3EndpointApSouthEast = "s3-ap-southeast-1.amazonaws.com" +s3EndpointApSouthEast2 :: B.ByteString+s3EndpointApSouthEast2 = "s3-ap-southeast-2.amazonaws.com"+ s3EndpointApNorthEast :: B.ByteString s3EndpointApNorthEast = "s3-ap-northeast-1.amazonaws.com" @@ -90,6 +94,7 @@ , s3Endpoint = endpoint , s3RequestStyle = BucketStyle , s3Port = defaultPort protocol+ , s3ServerSideEncryption = Nothing , s3UseUri = uri , s3DefaultExpiry = 15*60 }@@ -204,7 +209,7 @@ ] where amzHeader (k, v) = Blaze.copyByteString (CI.foldedCase k) `mappend` Blaze8.fromChar ':' `mappend` Blaze.copyByteString v (authorization, authQuery) = case ti of- AbsoluteTimestamp _ -> (Just $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], [])+ AbsoluteTimestamp _ -> (Just $ return $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], []) AbsoluteExpires time -> (Nothing, HTTP.toQuery $ makeAuthQuery time) makeAuthQuery time = [("Expires" :: B8.ByteString, fmtTimeEpochSeconds time)@@ -312,6 +317,17 @@ writeStorageClass Standard = "STANDARD" writeStorageClass ReducedRedundancy = "REDUCED_REDUNDANCY" +data ServerSideEncryption+ = AES256+ deriving (Show)++parseServerSideEncryption :: F.Failure XmlException m => T.Text -> m ServerSideEncryption+parseServerSideEncryption "AES256" = return AES256+parseServerSideEncryption s = F.failure . XmlException $ "Invalid Server Side Encryption: " ++ T.unpack s++writeServerSideEncryption :: ServerSideEncryption -> T.Text+writeServerSideEncryption AES256 = "AES256"+ type Bucket = T.Text data BucketInfo@@ -372,7 +388,7 @@ -- , omExpiration :: Maybe (UTCTime, T.Text) , omUserMetadata :: [(T.Text, T.Text)] , omMissingUserMetadata :: Maybe T.Text- , omServerSideEncryption :: Maybe T.Text+ , omServerSideEncryption :: Maybe ServerSideEncryption } deriving (Show) @@ -385,7 +401,7 @@ -- `ap` expiration `ap` return userMetadata `ap` return missingUserMetadata- `ap` return serverSideEncryption+ `ap` serverSideEncryption where deleteMarker = case B8.unpack `fmap` lookup "x-amz-delete-marker" h of Nothing -> return False Just "true" -> return True@@ -405,16 +421,20 @@ \(k, v) -> do i <- T.stripPrefix "x-amz-meta-" k return (i, v) missingUserMetadata = T.decodeUtf8 `fmap` lookup "x-amz-missing-meta" h- serverSideEncryption = T.decodeUtf8 `fmap` lookup "x-amz-server-side-encryption" h+ serverSideEncryption = case T.decodeUtf8 `fmap` lookup "x-amz-server-side-encryption" h of+ Just x -> return $ parseServerSideEncryption x+ Nothing -> return Nothing ht = map ((T.decodeUtf8 . CI.foldedCase) *** T.decodeUtf8) h type LocationConstraint = T.Text -locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationApSouthEast, locationApNorthEast :: LocationConstraint+locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationApSouthEast, locationApSouthEast2, locationApNorthEast :: LocationConstraint locationUsClassic = "" locationUsWest = "us-west-1" locationUsWest2 = "us-west-2" locationEu = "EU" locationApSouthEast = "ap-southeast-1"+locationApSouthEast2 = "ap-southeast-2" locationApNorthEast = "ap-northeast-1"+
README.org view
@@ -90,6 +90,11 @@ ** 0.8 series +- 0.8.5+ - compatibility with case-insensitive 1.2+ - support for V4 signatures+ - experimental support for DynamoDB+ - 0.8.4 - compatibility with http-conduit 2.0 @@ -215,3 +220,5 @@ | Ozgun Ataman | [[https://github.com/ozataman][ozataman]] | ozgun.ataman@soostone.com | [[http://soostone.com][Soostone Inc]] | Core, S3 | | 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 |+| John Lenz | [[https://github/com/wuzzeb][wuzzeb]] | | | DynamoDB, Core |
aws.cabal view
@@ -1,5 +1,5 @@ Name: aws-Version: 0.8.4+Version: 0.8.5 Synopsis: Amazon Web Services (AWS) for Haskell Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at <https://github.com/aristidb/aws/blob/master/README.org>. Homepage: http://github.com/aristidb/aws@@ -20,7 +20,7 @@ Source-repository this type: git location: https://github.com/aristidb/aws.git- tag: 0.8.4+ tag: 0.8.5 Source-repository head type: git@@ -92,15 +92,21 @@ Aws.Ses.Commands.SetIdentityNotificationTopic, Aws.Ses.Commands.SetIdentityDkimEnabled, Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled,- Aws.Ses.Core+ Aws.Ses.Core,+ Aws.DynamoDb.Commands,+ Aws.DynamoDb.Commands.Table,+ Aws.DynamoDb.Core Build-depends: attempt >= 0.3.1.1 && < 0.5,+ attoparsec-conduit >= 1.0 && < 1.1,+ aeson >= 0.6 && < 0.8, base == 4.*,+ base16-bytestring == 0.1.*, base64-bytestring == 1.0.*, blaze-builder >= 0.2.1.4 && < 0.4, bytestring >= 0.9 && < 0.11,- case-insensitive >= 0.2 && < 1.2,+ case-insensitive >= 0.2 && < 1.3, cereal >= 0.3 && < 0.5, conduit >= 1.0 && < 1.1, containers >= 0.4,@@ -121,7 +127,9 @@ text >= 0.11, time >= 1.1.4 && < 1.5, transformers >= 0.2.2.0 && < 0.4,+ unordered-containers >= 0.2, utf8-string == 0.3.*,+ vector >= 0.10, xml-conduit >= 1.1 && <1.2 GHC-Options: -Wall