diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -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 diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -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 : 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 diff --git a/Aws/DynamoDb/Commands.hs b/Aws/DynamoDb/Commands.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands.hs @@ -0,0 +1,5 @@ +module Aws.DynamoDb.Commands( + module Aws.DynamoDb.Commands.Table +) where + +import Aws.DynamoDb.Commands.Table diff --git a/Aws/DynamoDb/Commands/Table.hs b/Aws/DynamoDb/Commands/Table.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/Table.hs @@ -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 diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Core.hs @@ -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) 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 @@ -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 diff --git a/Aws/S3/Core.hs b/Aws/S3/Core.hs --- a/Aws/S3/Core.hs +++ b/Aws/S3/Core.hs @@ -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" + diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -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 | diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -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 . 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