aws 0.18 → 0.19
raw patch · 20 files changed
+422/−117 lines, 20 filesdep ~basedep ~bytestringdep ~conduitnew-component:exe:GetObjectV4
Dependency ranges changed: base, bytestring, conduit, conduit-extra, containers, http-conduit, resourcet, time
Files
- Aws/Aws.hs +1/−0
- Aws/Core.hs +138/−63
- Aws/DynamoDb/Core.hs +4/−0
- Aws/Iam/Core.hs +1/−1
- Aws/Network.hs +1/−1
- Aws/S3/Commands/CopyObject.hs +1/−1
- Aws/S3/Commands/DeleteObject.hs +2/−2
- Aws/S3/Commands/DeleteObjectVersion.hs +2/−2
- Aws/S3/Commands/GetService.hs +2/−2
- Aws/S3/Commands/HeadObject.hs +1/−1
- Aws/S3/Commands/Multipart.hs +2/−2
- Aws/S3/Commands/PutObject.hs +0/−8
- Aws/S3/Core.hs +182/−11
- Aws/Sqs/Core.hs +9/−1
- CHANGELOG.md +8/−0
- Examples/GetObjectGoogle.hs +1/−1
- Examples/GetObjectV4.hs +27/−0
- Examples/MultipartUpload.hs +17/−17
- Examples/PutBucketNearLine.hs +1/−1
- aws.cabal +22/−3
Aws/Aws.hs view
@@ -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)
Aws/Core.hs view
@@ -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 <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.@@ -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
Aws/DynamoDb/Core.hs view
@@ -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"
Aws/Iam/Core.hs view
@@ -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
Aws/Network.hs view
@@ -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
Aws/S3/Commands/CopyObject.hs view
@@ -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)
Aws/S3/Commands/DeleteObject.hs view
@@ -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
Aws/S3/Commands/DeleteObjectVersion.hs view
@@ -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
Aws/S3/Commands/GetService.hs view
@@ -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'
Aws/S3/Commands/HeadObject.hs view
@@ -31,7 +31,7 @@ data HeadObjectResponse = HeadObjectResponse { horMetadata :: Maybe ObjectMetadata- }+ } deriving (Show) data HeadObjectMemoryResponse = HeadObjectMemoryResponse (Maybe ObjectMetadata)
Aws/S3/Commands/Multipart.hs view
@@ -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
Aws/S3/Commands/PutObject.hs view
@@ -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
Aws/S3/Core.hs view
@@ -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+ -- * <http://docs.aws.amazon.com/general/latest/gr/sigv4_signing.html>+ -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-auth-using-authorization-header.html>+ -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html> + 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 <http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html>+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: <http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region>+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.<WA-DIR-N>.amazonaws.com+ -- s3-<WA-DIR-N>.amazonaws.com+ -- s3.<WA-DIR-N>.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"
Aws/Sqs/Core.hs view
@@ -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
CHANGELOG.md view
@@ -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 -----------
Examples/GetObjectGoogle.hs view
@@ -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
+ Examples/GetObjectV4.hs view
@@ -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"
Examples/MultipartUpload.hs view
@@ -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)
Examples/PutBucketNearLine.hs view
@@ -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. -}
aws.cabal view
@@ -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 <https://github.com/aristidb/aws/blob/master/README.md>. 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,