diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -242,6 +242,7 @@ logDebug $ "Host: " ++ show (HTTP.host httpRequest) logDebug $ "Path: " ++ show (HTTP.path httpRequest) logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest) + logDebug $ "Header: " ++ show (HTTP.requestHeaders httpRequest) case HTTP.requestBody httpRequest of HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show (L.take 1000 lbs) HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show (B.take 1000 bs) diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -52,7 +52,10 @@ , AuthorizationHash(..) , amzHash , signature +, credentialV4 , authorizationV4 +, authorizationV4' +, signatureV4 -- ** Query construction helpers , queryList , awsBool @@ -449,22 +452,14 @@ -- | Additional non-"amz" headers. , sqOtherHeaders :: !HTTP.RequestHeaders -- | Request body (used with 'Post' and 'Put'). -#if MIN_VERSION_http_conduit(2, 0, 0) , sqBody :: !(Maybe HTTP.RequestBody) -#else - , sqBody :: !(Maybe (HTTP.RequestBody (C.ResourceT IO))) -#endif -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes. , sqStringToSign :: !B.ByteString } --deriving (Show) -- | Create a HTTP request from a 'SignedQuery' object. -#if MIN_VERSION_http_conduit(2, 0, 0) queryToHttpRequest :: SignedQuery -> IO HTTP.Request -#else -queryToHttpRequest :: SignedQuery -> IO (HTTP.Request (C.ResourceT IO)) -#endif queryToHttpRequest SignedQuery{..} = do mauth <- maybe (return Nothing) (Just<$>) sqAuthorization return $ HTTP.defaultRequest { @@ -608,6 +603,26 @@ HmacSHA1 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA1) HmacSHA256 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA256) + +-- | Generates the Credential string, required for V4 signatures. +credentialV4 + :: SignatureData + -> B.ByteString -- ^ region, e.g. us-east-1 + -> B.ByteString -- ^ service, e.g. dynamodb + -> B.ByteString +credentialV4 sd region service = B.concat + [ accessKeyID (signatureCredentials sd) + , "/" + , date + , "/" + , region + , "/" + , service + , "/aws4_request" + ] + where + date = fmtTime "%Y%m%d" $ signatureTime sd + -- | 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. @@ -621,69 +636,129 @@ authorizationV4 sd ah region service headers canonicalRequest = do let ref = v4SigningKeys $ signatureCredentials sd date = fmtTime "%Y%m%d" $ signatureTime sd - mkHmac k i = case ah of - HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1) - HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256) - mkHash i = case ah of - HmacSHA1 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA1) - HmacSHA256 -> ByteArray.convert (CH.hash i :: CH.Digest CH.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 + 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 = mkHmac ("AWS4" <> secretKey) date - kRegion = mkHmac kDate region - kService = mkHmac kRegion service - kSigning = mkHmac 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 $ mkHash 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 $ mkHmac key stringToSign + let createNewKey = atomicModifyIORef ref $ \keylist -> + let kSigning = signingKeyV4 sd ah region service + lstK = (region,service) + keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist + in (keylist', kSigning) -- finally, return the header - return $ B.concat [ alg - , " Credential=" - , accessKeyID (signatureCredentials sd) - , "/" - , date - , "/" - , region - , "/" - , service - , "/aws4_request," - , "SignedHeaders=" - , headers - , ",Signature=" - , sig - ] + constructAuthorizationV4Header sd ah region service headers + . signatureV4WithKey sd ah region service canonicalRequest + <$> maybe createNewKey return mkey +-- | IO free version of @authorizationV4@, use this if you need +-- to compute the signature outside of IO. +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) + -> B.ByteString +authorizationV4' sd ah region service headers canonicalRequest + = constructAuthorizationV4Header sd ah region service headers + $ signatureV4 sd ah region service canonicalRequest + +constructAuthorizationV4Header + :: 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 -- ^ signature + -> B.ByteString +constructAuthorizationV4Header sd ah region service headers sig = B.concat + [ alg + , " Credential=" + , credentialV4 sd region service + , ",SignedHeaders=" + , headers + , ",Signature=" + , sig + ] + where + alg = case ah of + HmacSHA1 -> "AWS4-HMAC-SHA1" + HmacSHA256 -> "AWS4-HMAC-SHA256" + +-- | Compute the signature for V4 +signatureV4WithKey + :: SignatureData + -> AuthorizationHash + -> B.ByteString -- ^ region, e.g. us-east-1 + -> B.ByteString -- ^ service, e.g. dynamodb + -> B.ByteString -- ^ canonicalRequest (before hashing) + -> B.ByteString -- ^ signing key + -> B.ByteString +signatureV4WithKey sd ah region service canonicalRequest key = Base16.encode $ mkHmac key stringToSign + where + date = fmtTime "%Y%m%d" $ signatureTime sd + mkHmac k i = case ah of + HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1) + HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256) + mkHash i = case ah of + HmacSHA1 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA1) + HmacSHA256 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA256) + alg = case ah of + HmacSHA1 -> "AWS4-HMAC-SHA1" + HmacSHA256 -> "AWS4-HMAC-SHA256" + + -- now do the signature + canonicalRequestHash = Base16.encode $ mkHash canonicalRequest + stringToSign = B.concat + [ alg + , "\n" + , fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd + , "\n" + , date + , "/" + , region + , "/" + , service + , "/aws4_request\n" + , canonicalRequestHash + ] + +signingKeyV4 + :: SignatureData + -> AuthorizationHash + -> B.ByteString -- ^ region, e.g. us-east-1 + -> B.ByteString -- ^ service, e.g. dynamodb + -> B.ByteString +signingKeyV4 sd ah region service = kSigning + where + mkHmac k i = case ah of + HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1) + HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256) + date = fmtTime "%Y%m%d" $ signatureTime sd + secretKey = secretAccessKey $ signatureCredentials sd + kDate = mkHmac ("AWS4" <> secretKey) date + kRegion = mkHmac kDate region + kService = mkHmac kRegion service + kSigning = mkHmac kService "aws4_request" + +signatureV4 + :: SignatureData + -> AuthorizationHash + -> B.ByteString -- ^ region, e.g. us-east-1 + -> B.ByteString -- ^ service, e.g. dynamodb + -> B.ByteString -- ^ canonicalRequest (before hashing) + -> B.ByteString +signatureV4 sd ah region service canonicalRequest + = signatureV4WithKey sd ah region service canonicalRequest + $ signingKeyV4 sd ah region service + -- | Default configuration for a specific service. class DefaultServiceConfiguration config where -- | Default service configuration. @@ -748,7 +823,7 @@ <|> p "%a %b %_d %H:%M:%S %Y" s -- asctime-date <|> p "%Y-%m-%dT%H:%M:%S%QZ" s -- iso 8601 <|> p "%Y-%m-%dT%H:%M:%S%Q%Z" s -- iso 8601 - where p = parseTime defaultTimeLocale + where p = parseTimeM True defaultTimeLocale -- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) httpDate1 :: String diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -31,6 +31,7 @@ , ddbUsWest1 , ddbUsWest2 , ddbEuWest1 + , ddbEuWest2 , ddbEuCentral1 , ddbApNe1 , ddbApSe1 @@ -792,6 +793,9 @@ ddbEuWest1 :: Region ddbEuWest1 = Region "dynamodb.eu-west-1.amazonaws.com" "eu-west-1" + +ddbEuWest2 :: Region +ddbEuWest2 = Region "dynamodb.eu-west-2.amazonaws.com" "eu-west-2" ddbEuCentral1 :: Region ddbEuCentral1 = Region "dynamodb.eu-central-1.amazonaws.com" "eu-central-1" diff --git a/Aws/Iam/Core.hs b/Aws/Iam/Core.hs --- a/Aws/Iam/Core.hs +++ b/Aws/Iam/Core.hs @@ -162,7 +162,7 @@ -- | Parses IAM @DateTime@ data type. parseDateTime :: MonadThrow m => String -> m UTCTime parseDateTime x - = case parseTime defaultTimeLocale iso8601UtcDate x of + = case parseTimeM True defaultTimeLocale iso8601UtcDate x of Nothing -> throwM $ XmlException $ "Invalid DateTime: " ++ x Just dt -> return dt diff --git a/Aws/Network.hs b/Aws/Network.hs --- a/Aws/Network.hs +++ b/Aws/Network.hs @@ -15,6 +15,6 @@ remote@(SockAddrInet _ _) -> do v <- catch (timeout 100000 (connect sock remote) >>= return . isJust) (\(_ :: SomeException) -> return False) - sClose sock + close sock return v _ -> return False 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 @@ -98,7 +98,7 @@ (lastMod, etag) <- xmlCursorConsumer parse mref resp return $ CopyObjectResponse vid lastMod etag where parse el = do - let parseHttpDate' x = case parseTime defaultTimeLocale iso8601UtcDate x of + let parseHttpDate' x = case parseTimeM True defaultTimeLocale iso8601UtcDate x of Nothing -> throwM $ XmlException ("Invalid Last-Modified " ++ x) Just y -> return y lastMod <- forceM "Missing Last-Modified" $ el $/ elContent "LastModified" &| (parseHttpDate' . T.unpack) diff --git a/Aws/S3/Commands/DeleteObject.hs b/Aws/S3/Commands/DeleteObject.hs --- a/Aws/S3/Commands/DeleteObject.hs +++ b/Aws/S3/Commands/DeleteObject.hs @@ -10,10 +10,10 @@ data DeleteObject = DeleteObject { doObjectName :: T.Text, doBucket :: Bucket -} +} deriving (Show) data DeleteObjectResponse = DeleteObjectResponse{ -} +} deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery DeleteObject where diff --git a/Aws/S3/Commands/DeleteObjectVersion.hs b/Aws/S3/Commands/DeleteObjectVersion.hs --- a/Aws/S3/Commands/DeleteObjectVersion.hs +++ b/Aws/S3/Commands/DeleteObjectVersion.hs @@ -11,7 +11,7 @@ dovObjectName :: T.Text, dovBucket :: Bucket, dovVersionId :: T.Text -} +} deriving (Show) deleteObjectVersion :: Bucket -> T.Text -> T.Text -> DeleteObjectVersion deleteObjectVersion bucket object version @@ -22,7 +22,7 @@ } data DeleteObjectVersionResponse = DeleteObjectVersionResponse { -} +} deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery DeleteObjectVersion where diff --git a/Aws/S3/Commands/GetService.hs b/Aws/S3/Commands/GetService.hs --- a/Aws/S3/Commands/GetService.hs +++ b/Aws/S3/Commands/GetService.hs @@ -13,7 +13,7 @@ import qualified Data.Text as T import qualified Text.XML.Cursor as Cu -data GetService = GetService +data GetService = GetService deriving (Show) data GetServiceResponse = GetServiceResponse { @@ -35,7 +35,7 @@ parseBucket el = do name <- force "Missing owner Name" $ el $/ elContent "Name" creationDateString <- force "Missing owner CreationDate" $ el $/ elContent "CreationDate" &| T.unpack - creationDate <- force "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale iso8601UtcDate creationDateString + creationDate <- force "Invalid CreationDate" . maybeToList $ parseTimeM True defaultTimeLocale iso8601UtcDate creationDateString return BucketInfo { bucketName = name, bucketCreationDate = creationDate } -- | ServiceConfiguration: 'S3Configuration' 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 @@ -31,7 +31,7 @@ data HeadObjectResponse = HeadObjectResponse { horMetadata :: Maybe ObjectMetadata - } + } deriving (Show) data HeadObjectMemoryResponse = HeadObjectMemoryResponse (Maybe ObjectMetadata) diff --git a/Aws/S3/Commands/Multipart.hs b/Aws/S3/Commands/Multipart.hs --- a/Aws/S3/Commands/Multipart.hs +++ b/Aws/S3/Commands/Multipart.hs @@ -209,7 +209,7 @@ , cmurKey :: !T.Text , cmurETag :: !T.Text , cmurVersionId :: !(Maybe T.Text) - } + } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery CompleteMultipartUpload where @@ -296,7 +296,7 @@ data AbortMultipartUploadResponse = AbortMultipartUploadResponse { - } + } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery AbortMultipartUpload where 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 @@ -29,21 +29,13 @@ poStorageClass :: Maybe StorageClass, poWebsiteRedirectLocation :: Maybe T.Text, poServerSideEncryption :: Maybe ServerSideEncryption, -#if MIN_VERSION_http_conduit(2, 0, 0) poRequestBody :: HTTP.RequestBody, -#else - poRequestBody :: HTTP.RequestBody (C.ResourceT IO), -#endif poMetadata :: [(T.Text,T.Text)], poAutoMakeBucket :: Bool, -- ^ Internet Archive S3 nonstandard extension poExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10 } -#if MIN_VERSION_http_conduit(2, 0, 0) putObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject -#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 [] False False data PutObjectResponse diff --git a/Aws/S3/Core.hs b/Aws/S3/Core.hs --- a/Aws/S3/Core.hs +++ b/Aws/S3/Core.hs @@ -2,10 +2,11 @@ module Aws.S3.Core where import Aws.Core -import Control.Arrow ((***)) +import Control.Arrow (first, (***)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (MonadThrow, throwM) +import Data.Char (isAscii, isAlphaNum, toUpper, ord) import Data.Conduit (($$+-)) import Data.Function import Data.Functor ((<$>)) @@ -16,10 +17,12 @@ import Control.Applicative ((<|>)) import Data.Time import Data.Typeable +import Numeric (showHex) #if !MIN_VERSION_time(1,5,0) import System.Locale #endif import Text.XML.Cursor (($/), (&|)) +import qualified Data.Attoparsec.ByteString as Atto import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C @@ -27,9 +30,11 @@ import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import qualified Data.CaseInsensitive as CI import qualified Data.Conduit as C +import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP @@ -49,6 +54,17 @@ | VHostStyle deriving (Show) +data S3SignPayloadMode + = AlwaysUnsigned -- ^ Always use the "UNSIGNED-PAYLOAD" option. + | SignWithEffort -- ^ Sign the payload when 'HTTP.RequestBody' is a on-memory one ('HTTP.RequestBodyLBS' or 'HTTP.RequestBodyBS'). Otherwise use the "UNSINGED-PAYLOAD" option. + | AlwaysSigned -- ^ Always sign the payload. Note: 'error' called when 'HTTP.RequestBody' is a streaming one. + deriving (Eq, Show, Read, Typeable) + +data S3SignVersion + = S3SignV2 + | S3SignV4 { _s3SignPayloadMode :: S3SignPayloadMode } + deriving (Eq, Show, Read, Typeable) + data S3Configuration qt = S3Configuration { s3Protocol :: Protocol @@ -58,6 +74,7 @@ , s3ServerSideEncryption :: Maybe ServerSideEncryption , s3UseUri :: Bool , s3DefaultExpiry :: NominalDiffTime + , s3SignVersion :: S3SignVersion } deriving (Show) @@ -82,6 +99,9 @@ s3EndpointEu :: B.ByteString s3EndpointEu = "s3-eu-west-1.amazonaws.com" +s3EndpointEuWest2 :: B.ByteString +s3EndpointEuWest2 = "s3-eu-west-2.amazonaws.com" + s3EndpointApSouthEast :: B.ByteString s3EndpointApSouthEast = "s3-ap-southeast-1.amazonaws.com" @@ -101,8 +121,23 @@ , s3ServerSideEncryption = Nothing , s3UseUri = uri , s3DefaultExpiry = 15*60 + , s3SignVersion = S3SignV2 } +s3v4 :: Protocol -> B.ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt +s3v4 protocol endpoint uri payload + = S3Configuration + { s3Protocol = protocol + , s3Endpoint = endpoint + , s3RequestStyle = BucketStyle + , s3Port = defaultPort protocol + , s3ServerSideEncryption = Nothing + , s3UseUri = uri + , s3DefaultExpiry = 15*60 + , s3SignVersion = S3SignV4 payload + } + + type ErrorCode = T.Text data S3Error @@ -150,11 +185,7 @@ , s3QContentMd5 :: Maybe (CH.Digest CH.MD5) , s3QAmzHeaders :: HTTP.RequestHeaders , s3QOtherHeaders :: HTTP.RequestHeaders -#if MIN_VERSION_http_conduit(2, 0, 0) , s3QRequestBody :: Maybe HTTP.RequestBody -#else - , s3QRequestBody :: Maybe (HTTP.RequestBody (C.ResourceT IO)) -#endif } instance Show S3Query where @@ -166,8 +197,18 @@ " ; request body: " ++ (case s3QRequestBody of Nothing -> "no"; _ -> "yes") ++ "]" +hAmzDate, hAmzContentSha256, hAmzAlgorithm, hAmzCredential, hAmzExpires, hAmzSignedHeaders, hAmzSignature, hAmzSecurityToken :: HTTP.HeaderName +hAmzDate = "X-Amz-Date" +hAmzContentSha256 = "X-Amz-Content-Sha256" +hAmzAlgorithm = "X-Amz-Algorithm" +hAmzCredential = "X-Amz-Credential" +hAmzExpires = "X-Amz-Expires" +hAmzSignedHeaders = "X-Amz-SignedHeaders" +hAmzSignature = "X-Amz-Signature" +hAmzSecurityToken = "X-Amz-Security-Token" + s3SignQuery :: S3Query -> S3Configuration qt -> SignatureData -> SignedQuery -s3SignQuery S3Query{..} S3Configuration{..} SignatureData{..} +s3SignQuery S3Query{..} S3Configuration{ s3SignVersion = S3SignV2, .. } SignatureData{..} = SignedQuery { sqMethod = s3QMethod , sqProtocol = s3Protocol @@ -240,7 +281,136 @@ , ("AWSAccessKeyId", accessKeyID signatureCredentials) , ("SignatureMethod", "HmacSHA256") , ("Signature", sig)] ++ iamTok +s3SignQuery S3Query{..} S3Configuration{ s3SignVersion = S3SignV4 signpayload, .. } sd@SignatureData{..} + = SignedQuery + { sqMethod = s3QMethod + , sqProtocol = s3Protocol + , sqHost = B.intercalate "." $ catMaybes host + , sqPort = s3Port + , sqPath = mconcat $ catMaybes path + , sqQuery = queryString ++ signatureQuery :: HTTP.Query + , sqDate = Just signatureTime + , sqAuthorization = authorization + , sqContentType = s3QContentType + , sqContentMd5 = s3QContentMd5 + , sqAmzHeaders = Map.toList amzHeaders + , sqOtherHeaders = s3QOtherHeaders + , sqBody = s3QRequestBody + , sqStringToSign = stringToSign + } + where + -- V4 signing + -- * + -- * + -- * + iamTok = maybe [] (\x -> [(hAmzSecurityToken, x)]) $ iamToken signatureCredentials + + amzHeaders = Map.fromList $ (hAmzDate, sigTime):(hAmzContentSha256, payloadHash):iamTok ++ s3QAmzHeaders + where + -- needs to match the one produces in the @authorizationV4@ + sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime + payloadHash = case (signpayload, s3QRequestBody) of + (AlwaysUnsigned, _) -> "UNSIGNED-PAYLOAD" + (_, Nothing) -> emptyBodyHash + (_, Just (HTTP.RequestBodyLBS lbs)) -> Base16.encode $ ByteArray.convert (CH.hashlazy lbs :: CH.Digest CH.SHA256) + (_, Just (HTTP.RequestBodyBS bs)) -> Base16.encode $ ByteArray.convert (CH.hash bs :: CH.Digest CH.SHA256) + (SignWithEffort, _) -> "UNSIGNED-PAYLOAD" + (AlwaysSigned, _) -> error "aws: RequestBody must be a on-memory one when AlwaysSigned mode." + emptyBodyHash = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" + + (host, path) = case s3RequestStyle of + PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject]) + BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", urlEncodedS3QObject]) + VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/", urlEncodedS3QObject]) + where + urlEncodedS3QObject = s3UriEncode False <$> s3QObject + + -- must provide host in the canonical headers. + canonicalHeaders = Map.union amzHeaders . Map.fromList $ catMaybes + [ Just ("host", B.intercalate "." $ catMaybes host) + , ("content-type",) <$> s3QContentType + ] + signedHeaders = B8.intercalate ";" (map CI.foldedCase $ Map.keys canonicalHeaders) + stringToSign = B.intercalate "\n" $ + [ httpMethod s3QMethod -- method + , mconcat . catMaybes $ path -- path + , s3RenderQuery False $ sort queryString -- query string + ] ++ + Map.foldMapWithKey (\a b -> [CI.foldedCase a <> ":" <> b]) canonicalHeaders ++ + [ "" -- end headers + , signedHeaders + , amzHeaders Map.! hAmzContentSha256 + ] + + (authorization, signatureQuery, queryString) = case ti of + AbsoluteTimestamp _ -> (Just auth, [], allQueries) + AbsoluteExpires time -> + ( Nothing + , [(CI.original hAmzSignature, Just sig)] + , (allQueries ++) . HTTP.toQuery . map (first CI.original) $ + [ (hAmzAlgorithm, "AWS4-HMAC-SHA256") + , (hAmzCredential, cred) + , (hAmzDate, amzHeaders Map.! hAmzDate) + , (hAmzExpires, B8.pack . (show :: Integer -> String) . floor $ diffUTCTime time signatureTime) + , (hAmzSignedHeaders, signedHeaders) + ] ++ iamTok + ) + where + allQueries = s3QSubresources ++ s3QQuery + region = s3ExtractRegion s3Endpoint + auth = authorizationV4 sd HmacSHA256 region "s3" signedHeaders stringToSign + sig = signatureV4 sd HmacSHA256 region "s3" stringToSign + cred = credentialV4 sd region "s3" + ti = case (s3UseUri, signatureTimeInfo) of + (False, t) -> t + (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time + (True, AbsoluteExpires time) -> AbsoluteExpires time + +-- | Custom UriEncode function +-- see +s3UriEncode + :: Bool -- ^ Whether encode slash characters + -> B.ByteString + -> B.ByteString +s3UriEncode encodeSlash = B8.concatMap $ \c -> + if (isAscii c && isAlphaNum c) || (c `elem` nonEncodeMarks) + then B8.singleton c + else B8.pack $ '%' : map toUpper (showHex (ord c) "") + where + nonEncodeMarks :: String + nonEncodeMarks = if encodeSlash + then "_-~." + else "_-~./" + +s3RenderQuery + :: Bool -- ^ Whether prepend a question mark + -> HTTP.Query + -> B.ByteString +s3RenderQuery qm = mconcat . qmf . intersperse (B8.singleton '&') . map renderItem + where + qmf = if qm then ("?":) else id + + renderItem :: HTTP.QueryItem -> B8.ByteString + renderItem (k, Just v) = s3UriEncode True k <> "=" <> s3UriEncode True v + renderItem (k, Nothing) = s3UriEncode True k <> "=" + +-- | see: +s3ExtractRegion :: B.ByteString -> B.ByteString +s3ExtractRegion "s3.amazonaws.com" = "us-east-1" +s3ExtractRegion "s3-external-1.amazonaws.com" = "us-east-1" +s3ExtractRegion domain = either (const domain) B.pack $ Atto.parseOnly parser domain + where + -- s3.dualstack..amazonaws.com + -- s3-.amazonaws.com + -- s3..amazonaws.com + parser = do + _ <- Atto.string "s3" + _ <- Atto.string ".dualstack." <|> Atto.string "-" <|> Atto.string "." + r <- Atto.manyTill Atto.anyWord8 $ Atto.string ".amazonaws.com" + Atto.endOfInput + return r + s3ResponseConsumer :: HTTPResponseConsumer a -> IORef S3Metadata -> HTTPResponseConsumer a @@ -415,8 +585,8 @@ = do key <- force "Missing object Key" $ el $/ elContent "Key" versionId <- force "Missing object VersionId" $ el $/ elContent "VersionId" isLatest <- forceM "Missing object IsLatest" $ el $/ elContent "IsLatest" &| textReadBool - let time s = case (parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s) <|> - (parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of + let time s = case (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s) <|> + (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of Nothing -> throwM $ XmlException "Invalid time" Just v -> return v lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time @@ -466,8 +636,8 @@ parseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo parseObjectInfo el = do key <- force "Missing object Key" $ el $/ elContent "Key" - let time s = case (parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s) <|> - (parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of + let time s = case (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s) <|> + (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of Nothing -> throwM $ XmlException "Invalid time" Just v -> return v lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time @@ -540,11 +710,12 @@ type LocationConstraint = T.Text -locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint +locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuWest2, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint locationUsClassic = "" locationUsWest = "us-west-1" locationUsWest2 = "us-west-2" locationEu = "EU" +locationEuWest2 = "eu-west-2" locationEuFrankfurt = "eu-central-1" locationApSouthEast = "ap-southeast-1" locationApSouthEast2 = "ap-southeast-2" diff --git a/Aws/Sqs/Core.hs b/Aws/Sqs/Core.hs --- a/Aws/Sqs/Core.hs +++ b/Aws/Sqs/Core.hs @@ -2,7 +2,7 @@ module Aws.Sqs.Core where import Aws.Core -import Aws.S3.Core (LocationConstraint, locationUsClassic, locationUsWest, locationUsWest2, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationEu) +import Aws.S3.Core (LocationConstraint, locationUsClassic, locationUsWest, locationUsWest2, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationEu, locationEuWest2) import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C @@ -133,6 +133,14 @@ endpointHost = "eu-west-1.queue.amazonaws.com" , endpointDefaultLocationConstraint = locationEu , endpointAllowedLocationConstraints = [locationEu] + } + +sqsEndpointEuWest2 :: Endpoint +sqsEndpointEuWest2 + = Endpoint { + endpointHost = "eu-west-2.queue.amazonaws.com" + , endpointDefaultLocationConstraint = locationEuWest2 + , endpointAllowedLocationConstraints = [locationEuWest2] } sqsEndpointApSouthEast :: Endpoint diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.19 series +----------- + +- 0.19 + - Experimental support for V4 signing + - Add "eu-west-2" endpoint for some services + - Loosen http-conduit bounds + 0.18 series ----------- diff --git a/Examples/GetObjectGoogle.hs b/Examples/GetObjectGoogle.hs --- a/Examples/GetObjectGoogle.hs +++ b/Examples/GetObjectGoogle.hs @@ -10,7 +10,7 @@ main :: IO () main = do Just creds <- Aws.loadCredentialsFromEnv - let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) + let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False {- Set up a ResourceT region with an available HTTP manager. -} withManager $ \mgr -> do diff --git a/Examples/GetObjectV4.hs b/Examples/GetObjectV4.hs new file mode 100644 --- /dev/null +++ b/Examples/GetObjectV4.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Aws +import qualified Aws.Core as Aws +import qualified Aws.S3 as S3 +import Control.Monad.Trans.Resource +import Data.Conduit (($$+-)) +import Data.Conduit.Binary (sinkFile) +import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) + +main :: IO () +main = do + {- Set up AWS credentials and the default configuration. -} + Just creds <- Aws.loadCredentialsDefault + let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing + let s3cfg = S3.s3v4 Aws.HTTP "s3.amazonaws.com" False S3.SignWithEffort + + {- Set up a ResourceT region with an available HTTP manager. -} + mgr <- newManager tlsManagerSettings + runResourceT $ do + {- Create a request object with S3.getObject and run the request with pureAws. -} + S3.GetObjectResponse { S3.gorResponse = rsp } <- + Aws.pureAws cfg s3cfg mgr $ + S3.getObject "haskell-aws" "cloud-remote.pdf" + + {- Save the response to a file. -} + responseBody rsp $$+- sinkFile "cloud-remote.pdf" diff --git a/Examples/MultipartUpload.hs b/Examples/MultipartUpload.hs --- a/Examples/MultipartUpload.hs +++ b/Examples/MultipartUpload.hs @@ -1,30 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} import qualified Aws +import qualified Aws.Core as Aws import qualified Aws.S3 as S3 +import qualified Data.ByteString.Char8 as B import Data.Conduit (($$)) import Data.Conduit.Binary (sourceFile) import qualified Data.Text as T -import Network.HTTP.Conduit (withManager, responseBody) -import Control.Monad.Trans.Resource (ResourceT) +import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) +import Control.Monad.Trans.Resource (runResourceT) import System.Environment (getArgs) main :: IO () main = do - {- Set up AWS credentials and the default configuration. -} - cfg <- Aws.dbgConfiguration - let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery - args <- getArgs - - let doUpload bucket obj file chunkSize = - withManager $ \mgr -> do - (sourceFile file $$ S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024)) :: ResourceT IO () - case args of - [bucket,obj,file] -> - doUpload bucket obj file 10 - [bucket,obj,file,chunkSize] -> - doUpload bucket obj file (read chunkSize) - _ -> do - putStrLn "Usage: MultipartUpload bucket objectname filename (chunksize(MB)::optinal)" + [endpoint, bucket, obj, file] -> doUpload endpoint bucket obj file 10 + [endpoint, bucket, obj, file, chunkSize] -> doUpload endpoint bucket obj file (read chunkSize) + _ -> mapM_ putStrLn + [ "Usage: MultipartUpload endpoint bucket dstobject srcfile [chunksize(MB)]" + , "Example: MultipartUpload s3.us-east-2.amazonaws.com your-bucket tmp/test.bin test.bin" + ] + where + doUpload endpoint bucket obj file chunkSize = do + cfg <- Aws.dbgConfiguration + let s3cfg = S3.s3v4 Aws.HTTPS (B.pack endpoint) False S3.SignWithEffort + mgr <- newManager tlsManagerSettings + runResourceT $ + sourceFile file $$ S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024) diff --git a/Examples/PutBucketNearLine.hs b/Examples/PutBucketNearLine.hs --- a/Examples/PutBucketNearLine.hs +++ b/Examples/PutBucketNearLine.hs @@ -25,7 +25,7 @@ {- Set up AWS credentials and S3 configuration using the Google Cloud - Storage endpoint. -} Just creds <- Aws.loadCredentialsFromEnv - let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) + let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False {- Set up a ResourceT region with an available HTTP manager. -} diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -1,5 +1,5 @@ Name: aws -Version: 0.18 +Version: 0.19 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.18 + tag: 0.19 Source-repository head type: git @@ -130,7 +130,7 @@ data-default >= 0.5.3 && < 0.8, directory >= 1.0 && < 2.0, filepath >= 1.1 && < 1.5, - http-conduit >= 2.1 && < 2.3, + http-conduit >= 2.1 && < 2.4, http-types >= 0.7 && < 1.0, lifted-base >= 0.1 && < 0.3, memory, @@ -171,6 +171,24 @@ EmptyDataDecls, Rank2Types +Executable GetObjectV4 + Main-is: GetObjectV4.hs + Hs-source-dirs: Examples + + if !flag(Examples) + Buildable: False + else + Buildable: True + Build-depends: + base == 4.*, + aws, + http-conduit, + conduit, + conduit-extra, + resourcet + + Default-Language: Haskell2010 + Executable GetObject Main-is: GetObject.hs Hs-source-dirs: Examples @@ -216,6 +234,7 @@ Build-depends: base == 4.*, aws, + bytestring, http-conduit, conduit, conduit-extra,