diff --git a/amazonka-core.cabal b/amazonka-core.cabal --- a/amazonka-core.cabal +++ b/amazonka-core.cabal @@ -1,5 +1,5 @@ name: amazonka-core -version: 1.3.1 +version: 1.3.2 synopsis: Core data types and functionality for Amazonka libraries. homepage: https://github.com/brendanhay/amazonka bug-reports: https://github.com/brendanhay/amazonka/issues @@ -65,6 +65,10 @@ , Network.AWS.Types , Network.AWS.Waiter + other-modules: + Network.AWS.Sign.V4.Base + , Network.AWS.Sign.V4.Chunked + build-depends: aeson >= 0.8 , attoparsec >= 0.11.3 @@ -77,7 +81,7 @@ , cryptonite >= 0.4 , exceptions >= 0.6 , hashable >= 1.2 - , http-client >= 0.4.9 + , http-conduit >= 2.1.4 , http-types >= 0.8 , lens >= 4.4 , memory >= 0.6 diff --git a/src/Network/AWS/Data/Body.hs b/src/Network/AWS/Data/Body.hs --- a/src/Network/AWS/Data/Body.hs +++ b/src/Network/AWS/Data/Body.hs @@ -1,8 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + -- | -- Module : Network.AWS.Data.Body -- Copyright : (c) 2013-2015 Brendan Hay @@ -13,12 +20,17 @@ -- module Network.AWS.Data.Body where +import Control.Lens import Control.Monad.Trans.Resource import Data.Aeson +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS8 import Data.Conduit +import Data.HashMap.Strict (HashMap) +import Data.Monoid import Data.String import Data.Text (Text) import qualified Data.Text.Encoding as Text @@ -26,77 +38,189 @@ import qualified Data.Text.Lazy.Encoding as LText import Network.AWS.Data.ByteString import Network.AWS.Data.Crypto +import Network.AWS.Data.Log import Network.AWS.Data.Query (QueryString) import Network.AWS.Data.XML (encodeXML) -import Network.HTTP.Client +import Network.HTTP.Conduit import Text.XML (Element) import Prelude +default (Builder) + -- | A streaming, exception safe response body. newtype RsBody = RsBody - { bodyResponse :: ResumableSource (ResourceT IO) ByteString + { _streamBody :: ResumableSource (ResourceT IO) ByteString } +-- newtype for show/orhpan instance purposes. instance Show RsBody where show = const "RsBody { ResumableSource (ResourceT IO) ByteString }" --- | An opaque request body containing a 'SHA256' hash. -data RqBody = RqBody - { bodySHA256 :: Digest SHA256 - , bodyRequest :: RequestBody +fuseStream :: RsBody + -> Conduit ByteString (ResourceT IO) ByteString + -> RsBody +fuseStream b f = b { _streamBody = _streamBody b $=+ f } + +-- | Specifies the transmitted size of the 'Transfer-Encoding' chunks. +-- +-- /See:/ 'defaultChunk'. +newtype ChunkSize = ChunkSize Int + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) + +instance ToLog ChunkSize where + build = build . show + +-- | The default chunk size of 128 KB. The minimum chunk size accepted by +-- AWS is 8 KB, unless the entirety of the request is below this threshold. +-- +-- A chunk size of 64 KB or higher is recommended for performance reasons. +defaultChunkSize :: ChunkSize +defaultChunkSize = 128 * 1024 + +-- | An opaque request body which will be transmitted via +-- @Transfer-Encoding: chunked@. +-- +-- /Invariant:/ Only services that support chunked encoding can +-- accept a 'ChunkedBody'. (Currently S3.) This is enforced by the type +-- signatures emitted by the generator. +data ChunkedBody = ChunkedBody + { _chunkedSize :: !ChunkSize + , _chunkedLength :: !Integer + , _chunkedBody :: Source (ResourceT IO) ByteString } -instance Show RqBody where - show b = "RqBody { RequestBody " - ++ BS8.unpack (digestToBase Base16 (bodySHA256 b)) ++ " }" +chunkedLength :: Lens' ChunkedBody Integer +chunkedLength = lens _chunkedLength (\s a -> s { _chunkedLength = a }) +-- Maybe revert to using Source's, and then enforce the chunk size +-- during conversion from HashedBody -> ChunkedBody + +instance Show ChunkedBody where + show c = BS8.unpack . toBS $ build + "ChunkedBody { chunkSize = " + <> build (_chunkedSize c) + <> "<> originalLength = " + <> build (_chunkedLength c) + <> "<> fullChunks = " + <> build (fullChunks c) + <> "<> remainderBytes = " + <> build (remainderBytes c) + <> "}" + +fuseChunks :: ChunkedBody + -> Conduit ByteString (ResourceT IO) ByteString + -> ChunkedBody +fuseChunks c f = c { _chunkedBody = _chunkedBody c =$= f } + +fullChunks :: ChunkedBody -> Integer +fullChunks c = _chunkedLength c `div` fromIntegral (_chunkedSize c) + +remainderBytes :: ChunkedBody -> Maybe Integer +remainderBytes c = + case _chunkedLength c `mod` toInteger (_chunkedSize c) of + 0 -> Nothing + n -> Just n + +-- | An opaque request body containing a 'SHA256' hash. +data HashedBody + = HashedStream (Digest SHA256) !Integer (Source (ResourceT IO) ByteString) + | HashedBytes (Digest SHA256) ByteString + +instance Show HashedBody where + show = \case + HashedStream h n _ -> str "HashedStream" h n + HashedBytes h x -> str "HashedBody" h (BS.length x) + where + str c h n = BS8.unpack . toBS $ + c <> " { sha256 = " + <> build (digestToBase Base16 h) + <> ", length = " + <> build n + +instance IsString HashedBody where + fromString = toHashed + +sha256Base16 :: HashedBody -> ByteString +sha256Base16 = digestToBase Base16 . \case + HashedStream h _ _ -> h + HashedBytes h _ -> h + +-- | Invariant: only services that support _both_ standard and +-- chunked signing expose 'RqBody' as a parameter. +data RqBody + = Chunked ChunkedBody + | Hashed HashedBody + deriving (Show) + instance IsString RqBody where - fromString = toBody . LBS8.pack + fromString = Hashed . fromString -bodyStream :: RqBody -> Bool -bodyStream x = - case bodyRequest x of - RequestBodyLBS {} -> False - RequestBodyBS {} -> False - RequestBodyBuilder {} -> False - RequestBodyStream {} -> True - RequestBodyStreamChunked {} -> True +md5Base64 :: RqBody -> Maybe ByteString +md5Base64 = \case + Hashed (HashedBytes _ x) -> Just . digestToBase Base64 $ hashMD5 x + _ -> Nothing -bodyCalculateMD5 :: RqBody -> Maybe (Digest MD5) -bodyCalculateMD5 x = - let md5 = Just . hashMD5 - in case bodyRequest x of - RequestBodyLBS lbs -> md5 (toBS lbs) - RequestBodyBS bs -> md5 bs - RequestBodyBuilder _ b -> md5 (toBS b) - _ -> Nothing +isStreaming :: RqBody -> Bool +isStreaming = \case + Hashed (HashedStream {}) -> True + _ -> False --- | Anything that can be safely converted to a 'RqBody'. -class ToBody a where - -- | Convert a value to a request body. - toBody :: a -> RqBody +toRequestBody :: RqBody -> RequestBody +toRequestBody = \case + Chunked x -> requestBodySourceChunked (_chunkedBody x) + Hashed x -> case x of + HashedStream _ n f -> requestBodySource (fromIntegral n) f + HashedBytes _ b -> RequestBodyBS b -instance ToBody RqBody where - toBody = id +contentLength :: RqBody -> Integer +contentLength = \case + Chunked x -> _chunkedLength x + Hashed x -> case x of + HashedStream _ n _ -> n + HashedBytes _ b -> fromIntegral (BS.length b) -instance ToBody LBS.ByteString where - toBody x = RqBody (hashlazy x) (RequestBodyLBS x) +-- | Anything that can be safely converted to a 'HashedBody'. +class ToHashedBody a where + -- | Convert a value to a hashed request body. + toHashed :: a -> HashedBody -instance ToBody ByteString where - toBody x = RqBody (hash x) (RequestBodyBS x) +instance ToHashedBody ByteString where + toHashed x = HashedBytes (hash x) x -instance ToBody Text where - toBody = toBody . Text.encodeUtf8 +instance ToHashedBody HashedBody where toHashed = id +instance ToHashedBody String where toHashed = toHashed . LBS8.pack +instance ToHashedBody LBS.ByteString where toHashed = toHashed . toBS +instance ToHashedBody Text where toHashed = toHashed . Text.encodeUtf8 +instance ToHashedBody LText.Text where toHashed = toHashed . LText.encodeUtf8 +instance ToHashedBody Value where toHashed = toHashed . encode +instance ToHashedBody Element where toHashed = toHashed . encodeXML +instance ToHashedBody QueryString where toHashed = toHashed . toBS -instance ToBody LText.Text where - toBody = toBody . LText.encodeUtf8 +instance ToHashedBody (HashMap Text Value) where + toHashed = toHashed . Object -instance ToBody Value where - toBody = toBody . encode +-- | Anything that can be converted to a streaming request 'Body'. +class ToBody a where + -- | Convert a value to a request body. + toBody :: a -> RqBody -instance ToBody Element where - toBody = toBody . encodeXML + default toBody :: ToHashedBody a => a -> RqBody + toBody = Hashed . toHashed -instance ToBody QueryString where - toBody = toBody . toBS +instance ToBody RqBody where toBody = id +instance ToBody HashedBody where toBody = Hashed +instance ToBody ChunkedBody where toBody = Chunked + +instance ToBody String +instance ToBody LBS.ByteString +instance ToBody ByteString +instance ToBody Text +instance ToBody LText.Text +instance ToBody (HashMap Text Value) +instance ToBody Value +instance ToBody Element +instance ToBody QueryString + +_Body :: ToBody a => AReview RqBody a +_Body = un (to toBody) diff --git a/src/Network/AWS/Data/Headers.hs b/src/Network/AWS/Data/Headers.hs --- a/src/Network/AWS/Data/Headers.hs +++ b/src/Network/AWS/Data/Headers.hs @@ -31,6 +31,7 @@ infixl 7 .#, .#? +-- FIXME: This whole toText/fromText shit is just stupid. (.#) :: FromText a => ResponseHeaders -> HeaderName -> Either String a hs .# k = hs .#? k >>= note where @@ -111,6 +112,12 @@ hAMZNAuth :: HeaderName hAMZNAuth = "X-Amzn-Authorization" + +hAMZDecodedContentLength :: HeaderName +hAMZDecodedContentLength = "X-Amz-Decoded-Content-Length" + +hTransferEncoding :: HeaderName +hTransferEncoding = "Transfer-Encoding" hFormEncoded :: ByteString hFormEncoded = "application/x-www-form-urlencoded; charset=utf-8" diff --git a/src/Network/AWS/Data/Log.hs b/src/Network/AWS/Data/Log.hs --- a/src/Network/AWS/Data/Log.hs +++ b/src/Network/AWS/Data/Log.hs @@ -37,7 +37,7 @@ import Network.AWS.Data.Path import Network.AWS.Data.Query import Network.AWS.Data.Text -import Network.HTTP.Client +import Network.HTTP.Conduit import Network.HTTP.Types import Numeric diff --git a/src/Network/AWS/Error.hs b/src/Network/AWS/Error.hs --- a/src/Network/AWS/Error.hs +++ b/src/Network/AWS/Error.hs @@ -25,7 +25,7 @@ import Network.AWS.Data.Text import Network.AWS.Data.XML import Network.AWS.Types -import Network.HTTP.Client +import Network.HTTP.Conduit import Network.HTTP.Types.Status (Status (..)) statusSuccess :: Status -> Bool diff --git a/src/Network/AWS/Request.hs b/src/Network/AWS/Request.hs --- a/src/Network/AWS/Request.hs +++ b/src/Network/AWS/Request.hs @@ -35,7 +35,6 @@ , defaultRequest -- ** Hashing - , contentSHA256 , contentMD5 -- ** Lenses @@ -49,16 +48,15 @@ import Data.Monoid import Network.AWS.Data.Body import Network.AWS.Data.ByteString -import Network.AWS.Data.Crypto import Network.AWS.Data.Headers import Network.AWS.Data.JSON import Network.AWS.Data.Path import Network.AWS.Data.Query import Network.AWS.Data.XML import Network.AWS.Types -import qualified Network.HTTP.Client.Internal as Client -import Network.HTTP.Types (StdMethod (..)) -import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Conduit as Client +import Network.HTTP.Types (StdMethod (..)) +import qualified Network.HTTP.Types as HTTP type ToRequest a = (ToPath a, ToQuery a, ToHeaders a) @@ -69,7 +67,7 @@ delete s x = get s x & rqMethod .~ DELETE get :: ToRequest a => Service -> a -> Request a -get s = contentSHA256 . defaultRequest s +get s = defaultRequest s post :: ToRequest a => Service -> a -> Request a post s x = get s x & rqMethod .~ POST @@ -91,7 +89,7 @@ , _rqQuery = mempty , _rqBody = toBody (toQuery x) , _rqHeaders = hdr hContentType hFormEncoded (toHeaders x) - } & contentSHA256 + } postBody :: (ToRequest a, ToBody a) => Service -> a -> Request a postBody s x = putBody s x & rqMethod .~ POST @@ -100,19 +98,16 @@ putXML s x = defaultRequest s x & rqMethod .~ PUT & rqBody .~ toBody (toElement x) - & contentSHA256 putJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a putJSON s x = defaultRequest s x & rqMethod .~ PUT & rqBody .~ toBody (toJSON x) - & contentSHA256 putBody :: (ToRequest a, ToBody a) => Service -> a -> Request a putBody s x = defaultRequest s x & rqMethod .~ PUT & rqBody .~ toBody x - & contentSHA256 defaultRequest :: ToRequest a => Service -> a -> Request a defaultRequest s x = Request @@ -124,17 +119,13 @@ , _rqBody = "" } -contentSHA256 :: Request a -> Request a -contentSHA256 rq = rq & rqHeaders %~ - hdr hAMZContentSHA256 (rq ^. rqBody . to (digestToBase Base16 . bodySHA256)) - contentMD5 :: Request a -> Request a contentMD5 rq | missing, Just x <- md5 = rq & rqHeaders %~ hdr HTTP.hContentMD5 x | otherwise = rq where - missing = isNothing $ lookup HTTP.hContentMD5 (rq ^. rqHeaders) - md5 = rq ^. rqBody . to (fmap (digestToBase Base64) . bodyCalculateMD5) + missing = isNothing $ lookup HTTP.hContentMD5 (_rqHeaders rq) + md5 = md5Base64 (_rqBody rq) queryString :: Lens' Client.Request ByteString queryString f x = diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs --- a/src/Network/AWS/Response.hs +++ b/src/Network/AWS/Response.hs @@ -28,7 +28,7 @@ import Network.AWS.Data.Log import Network.AWS.Data.XML import Network.AWS.Types -import Network.HTTP.Client hiding (Proxy, Request, Response) +import Network.HTTP.Conduit hiding (Proxy, Request, Response) import Network.HTTP.Types import Text.XML (Node) @@ -110,7 +110,7 @@ -> Proxy a -> ClientResponse -> m (Response a) -receive f Service{..} _ rs +receive f Service{..} _ rs | not (_svcCheck s) = sinkLBS x >>= serviceErr | otherwise = do p <- f (fromEnum s) h x diff --git a/src/Network/AWS/Sign/V2.hs b/src/Network/AWS/Sign/V2.hs --- a/src/Network/AWS/Sign/V2.hs +++ b/src/Network/AWS/Sign/V2.hs @@ -17,7 +17,7 @@ ) where import Control.Applicative -import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Char8 as BS8 import Data.Monoid import Data.Time import Network.AWS.Data.Body @@ -29,8 +29,8 @@ import Network.AWS.Data.Query import Network.AWS.Data.Time import Network.AWS.Types -import qualified Network.HTTP.Client.Internal as Client -import Network.HTTP.Types hiding (toQuery) +import qualified Network.HTTP.Conduit as Client +import Network.HTTP.Types hiding (toQuery) import Prelude @@ -50,10 +50,10 @@ ] v2 :: Signer -v2 = Signer sign' (const sign') -- FIXME: revisit v2 presigning. +v2 = Signer sign (const sign) -- FIXME: revisit v2 presigning. -sign' :: Algorithm a -sign' Request{..} AuthEnv{..} r t = Signed meta rq +sign :: Algorithm a +sign Request{..} AuthEnv{..} r t = Signed meta rq where meta = Meta (V2 t end signature) @@ -62,7 +62,7 @@ , Client.path = path' , Client.queryString = toBS authorised , Client.requestHeaders = headers - , Client.requestBody = bodyRequest _rqBody + , Client.requestBody = toRequestBody _rqBody } meth = toBS _rqMethod diff --git a/src/Network/AWS/Sign/V4.hs b/src/Network/AWS/Sign/V4.hs --- a/src/Network/AWS/Sign/V4.hs +++ b/src/Network/AWS/Sign/V4.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Network.AWS.Sign.V4 @@ -18,271 +20,55 @@ module Network.AWS.Sign.V4 ( V4 (..) , v4 - , metadata ) where import Control.Applicative import Control.Lens -import Data.Bifunctor -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.CaseInsensitive as CI -import qualified Data.Foldable as Fold -import Data.Function (on) -import Data.List (nubBy, sortBy) +import qualified Data.CaseInsensitive as CI import Data.Monoid -import GHC.TypeLits import Network.AWS.Data.Body import Network.AWS.Data.ByteString -import Network.AWS.Data.Crypto import Network.AWS.Data.Headers -import Network.AWS.Data.Log -import Network.AWS.Data.Path import Network.AWS.Data.Query import Network.AWS.Data.Time import Network.AWS.Request +import Network.AWS.Sign.V4.Base +import Network.AWS.Sign.V4.Chunked import Network.AWS.Types -import qualified Network.HTTP.Client.Internal as Client -import Network.HTTP.Types.Header import Prelude -data V4 = V4 - { metaTime :: !UTCTime - , metaMethod :: !Method - , metaPath :: !Path - , metaEndpoint :: !Endpoint - , metaCredential :: !Credential - , metaCanonicalQuery :: !CanonicalQuery - , metaCanonicalRequest :: !CanonicalRequest - , metaCanonicalHeaders :: !CanonicalHeaders - , metaSignedHeaders :: !SignedHeaders - , metaStringToSign :: !StringToSign - , metaSignature :: !Signature - , metaHeaders :: ![Header] - , metaBody :: Client.RequestBody - , metaTimeout :: !(Maybe Seconds) - } - -instance ToLog V4 where - build V4{..} = buildLines - [ "[Version 4 Metadata] {" - , " time = " <> build metaTime - , " endpoint = " <> build (_endpointHost metaEndpoint) - , " credential = " <> build metaCredential - , " signed headers = " <> build metaSignedHeaders - , " signature = " <> build metaSignature - , " string to sign = {" - , build metaStringToSign - , "}" - , " canonical request = {" - , build metaCanonicalRequest - , " }" - , "}" - ] +default (ByteString) v4 :: Signer -v4 = Signer sign' presign' +v4 = Signer sign presign -presign' :: Seconds -> Algorithm a -presign' ex rq auth reg ts = finalise meta authorise +presign :: Seconds -> Algorithm a +presign ex rq a r ts = signRequest meta mempty auth where - authorise = queryString - <>~ ("&X-Amz-Signature=" <> toBS (metaSignature meta)) + auth = queryString <>~ ("&X-Amz-Signature=" <> toBS (metaSignature meta)) - meta = metadata auth reg ts presign digest (prepare rq) + meta = signMetadata a r ts presigner digest (prepare rq) - presign c shs = + presigner c shs = pair (CI.original hAMZAlgorithm) algorithm . pair (CI.original hAMZCredential) (toBS c) . pair (CI.original hAMZDate) (Time ts :: AWSTime) . pair (CI.original hAMZExpires) ex . pair (CI.original hAMZSignedHeaders) (toBS shs) - . pair (CI.original hAMZToken) (toBS <$> _authToken auth) + . pair (CI.original hAMZToken) (toBS <$> _authToken a) digest = Tag "UNSIGNED-PAYLOAD" prepare = rqHeaders .~ [] -sign' :: Algorithm a -sign' rq auth reg ts = finalise meta authorise - where - authorise = requestHeaders - <>~ [(hAuthorization, authorisation meta)] - - meta = metadata auth reg ts presign digest (prepare rq) - - presign _ _ = id - - digest = Tag . digestToBase Base16 . bodySHA256 $ _rqBody rq - - prepare = rqHeaders %~ - ( hdr hHost (_endpointHost end) - . hdr hAMZDate (toBS (Time ts :: AWSTime)) - . maybe id (hdr hAMZToken . toBS) (_authToken auth) - ) - - end = _svcEndpoint (_rqService rq) reg - --- | Used to tag provenance. This allows keeping the same layout as --- the signing documentation, passing 'ByteString's everywhere, with --- some type guarantees. --- --- Data.Tagged is not used for no reason other than syntactic length and --- the ToByteString instance. -newtype Tag (s :: Symbol) a = Tag { unTag :: a } - -instance ToByteString (Tag s ByteString) where toBS = unTag -instance ToLog (Tag s ByteString) where build = build . unTag - -instance ToByteString CredentialScope where - toBS = BS8.intercalate "/" . unTag - -type Hash = Tag "body-digest" ByteString -type StringToSign = Tag "string-to-sign" ByteString -type Credential = Tag "credential" ByteString -type CredentialScope = Tag "credential-scope" [ByteString] -type CanonicalRequest = Tag "canonical-request" ByteString -type CanonicalHeaders = Tag "canonical-headers" ByteString -type CanonicalQuery = Tag "canonical-query" ByteString -type SignedHeaders = Tag "signed-headers" ByteString -type NormalisedHeaders = Tag "normalised-headers" [(ByteString, ByteString)] -type Method = Tag "method" ByteString -type Path = Tag "path" ByteString -type Signature = Tag "signature" ByteString - -authorisation :: V4 -> ByteString -authorisation V4{..} = algorithm - <> " Credential=" <> toBS metaCredential - <> ", SignedHeaders=" <> toBS metaSignedHeaders - <> ", Signature=" <> toBS metaSignature - -finalise :: V4 -> (ClientRequest -> ClientRequest) -> Signed a -finalise m@V4{..} authorise = Signed (Meta m) (authorise rq) - where - rq = (clientRequest metaEndpoint metaTimeout) - { Client.method = toBS metaMethod - , Client.path = toBS metaPath - , Client.queryString = qry - , Client.requestHeaders = metaHeaders - , Client.requestBody = metaBody - } - - qry | BS.null x = x - | otherwise = '?' `BS8.cons` x - where - x = toBS metaCanonicalQuery - -metadata :: AuthEnv - -> Region - -> UTCTime - -> (Credential -> SignedHeaders -> QueryString -> QueryString) - -> Hash - -> Request a - -> V4 -metadata auth reg ts presign digest rq = V4 - { metaTime = ts - , metaMethod = method - , metaPath = path - , metaEndpoint = end - , metaCredential = cred - , metaCanonicalQuery = query - , metaCanonicalRequest = crq - , metaCanonicalHeaders = chs - , metaSignedHeaders = shs - , metaStringToSign = sts - , metaSignature = signature (_authSecret auth) scope sts - , metaHeaders = _rqHeaders rq - , metaBody = bodyRequest (_rqBody rq) - , metaTimeout = _svcTimeout svc - } - where - query = canonicalQuery . presign cred shs $ _rqQuery rq - - sts = stringToSign ts scope crq - cred = credential (_authAccess auth) scope - scope = credentialScope svc end ts - crq = canonicalRequest method path digest query chs shs - - chs = canonicalHeaders headers - shs = signedHeaders headers - headers = normaliseHeaders (_rqHeaders rq) - - end = _svcEndpoint svc reg - method = Tag . toBS $ _rqMethod rq - path = escapedPath rq - - svc = _rqService rq - -algorithm :: ByteString -algorithm = "AWS4-HMAC-SHA256" - -signature :: SecretKey -> CredentialScope -> StringToSign -> Signature -signature k c = Tag . digestToBase Base16 . hmacSHA256 signingKey . unTag - where - signingKey = Fold.foldl' hmac ("AWS4" <> toBS k) (unTag c) - - hmac x y = digestToBS (hmacSHA256 x y) - -stringToSign :: UTCTime -> CredentialScope -> CanonicalRequest -> StringToSign -stringToSign t c r = Tag $ BS8.intercalate "\n" - [ algorithm - , toBS (Time t :: AWSTime) - , toBS c - , digestToBase Base16 . hashSHA256 $ toBS r - ] - -credential :: AccessKey -> CredentialScope -> Credential -credential k c = Tag (toBS k <> "/" <> toBS c) - -credentialScope :: Service -> Endpoint -> UTCTime -> CredentialScope -credentialScope s e t = Tag - [ toBS (Time t :: BasicTime) - , toBS (_endpointScope e) - , toBS (_svcPrefix s) - , "aws4_request" - ] - -canonicalRequest :: Method - -> Path - -> Hash - -> CanonicalQuery - -> CanonicalHeaders - -> SignedHeaders - -> CanonicalRequest -canonicalRequest meth path digest query chs shs = Tag $ - BS8.intercalate "\n" - [ toBS meth - , toBS path - , toBS query - , toBS chs - , toBS shs - , toBS digest - ] - -escapedPath :: Request a -> Path -escapedPath r = Tag . toBS . escapePath $ - case _svcAbbrev (_rqService r) of - "S3" -> _rqPath r - _ -> collapsePath (_rqPath r) - -canonicalQuery :: QueryString -> CanonicalQuery -canonicalQuery = Tag . toBS - --- FIXME: the following use of stripBS is too naive, should remove --- all internal whitespace, replacing with a single space char, --- unless quoted with \"...\" -canonicalHeaders :: NormalisedHeaders -> CanonicalHeaders -canonicalHeaders = Tag . Fold.foldMap (uncurry f) . unTag - where - f k v = k <> ":" <> stripBS v <> "\n" - -signedHeaders :: NormalisedHeaders -> SignedHeaders -signedHeaders = Tag . BS8.intercalate ";" . map fst . unTag +sign :: Algorithm a +sign rq a r ts = + case _rqBody rq of + Chunked x -> chunked x rq a r ts + Hashed x -> hashed x rq a r ts -normaliseHeaders :: [Header] -> NormalisedHeaders -normaliseHeaders = Tag - . map (first CI.foldedCase) - . nubBy ((==) `on` fst) - . sortBy (compare `on` fst) - . filter ((/= "authorization") . fst) +hashed :: HashedBody -> Algorithm a +hashed x rq a r ts = + let (meta, auth) = base (Tag (sha256Base16 x)) rq a r ts + in signRequest meta (toRequestBody (Hashed x)) auth diff --git a/src/Network/AWS/Sign/V4/Base.hs b/src/Network/AWS/Sign/V4/Base.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Sign/V4/Base.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.AWS.Sign.V4.Base +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Sign.V4.Base where + +import Control.Applicative +import Control.Lens +import Data.Bifunctor +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +import qualified Data.Foldable as Fold +import Data.Function (on) +import Data.List (nubBy, sortBy) +import Data.Maybe +import Data.Monoid +import GHC.TypeLits +import Network.AWS.Data.ByteString +import Network.AWS.Data.Crypto +import Network.AWS.Data.Headers +import Network.AWS.Data.Log +import Network.AWS.Data.Path +import Network.AWS.Data.Query +import Network.AWS.Data.Time +import Network.AWS.Request +import Network.AWS.Types +import qualified Network.HTTP.Conduit as Client +import Network.HTTP.Types.Header + +import Prelude + +default (ByteString) + +data V4 = V4 + { metaTime :: !UTCTime + , metaMethod :: !Method + , metaPath :: !Path + , metaEndpoint :: !Endpoint + , metaCredential :: !Credential + , metaCanonicalQuery :: !CanonicalQuery + , metaCanonicalRequest :: !CanonicalRequest + , metaCanonicalHeaders :: !CanonicalHeaders + , metaSignedHeaders :: !SignedHeaders + , metaStringToSign :: !StringToSign + , metaSignature :: !Signature + , metaHeaders :: ![Header] + , metaTimeout :: !(Maybe Seconds) + } + +instance ToLog V4 where + build V4{..} = buildLines + [ "[Version 4 Metadata] {" + , " time = " <> build metaTime + , " endpoint = " <> build (_endpointHost metaEndpoint) + , " credential = " <> build metaCredential + , " signed headers = " <> build metaSignedHeaders + , " signature = " <> build metaSignature + , " string to sign = {" + , build metaStringToSign + , "}" + , " canonical request = {" + , build metaCanonicalRequest + , " }" + , "}" + ] + +base :: Hash + -> Request a + -> AuthEnv + -> Region + -> UTCTime + -> (V4, ClientRequest -> ClientRequest) +base h rq a r ts = (meta, auth) + where + auth = requestHeaders <>~ [(hAuthorization, authorisation meta)] + + meta = signMetadata a r ts presigner h (prepare rq) + + presigner _ _ = id + + prepare = rqHeaders %~ + ( hdr hHost (_endpointHost end) + . hdr hAMZDate (toBS (Time ts :: AWSTime)) + . hdr hAMZContentSHA256 (toBS h) + . maybe id (hdr hAMZToken . toBS) (_authToken a) + ) + + end = _svcEndpoint (_rqService rq) r + +-- | Used to tag provenance. This allows keeping the same layout as +-- the signing documentation, passing 'ByteString's everywhere, with +-- some type guarantees. +-- +-- Data.Tagged is not used for no reason other than syntactic length and +-- the ToByteString instance. +newtype Tag (s :: Symbol) a = Tag { unTag :: a } deriving (Show) + +instance ToByteString (Tag s ByteString) where toBS = unTag +instance ToLog (Tag s ByteString) where build = build . unTag + +instance ToByteString CredentialScope where + toBS = BS8.intercalate "/" . unTag + +type Hash = Tag "body-digest" ByteString +type StringToSign = Tag "string-to-sign" ByteString +type Credential = Tag "credential" ByteString +type CredentialScope = Tag "credential-scope" [ByteString] +type CanonicalRequest = Tag "canonical-request" ByteString +type CanonicalHeaders = Tag "canonical-headers" ByteString +type CanonicalQuery = Tag "canonical-query" ByteString +type SignedHeaders = Tag "signed-headers" ByteString +type NormalisedHeaders = Tag "normalised-headers" [(ByteString, ByteString)] +type Method = Tag "method" ByteString +type Path = Tag "path" ByteString +type Signature = Tag "signature" ByteString + +authorisation :: V4 -> ByteString +authorisation V4{..} = algorithm + <> " Credential=" <> toBS metaCredential + <> ", SignedHeaders=" <> toBS metaSignedHeaders + <> ", Signature=" <> toBS metaSignature + +signRequest :: V4 -- ^ Pre-signRequestd signing metadata. + -> Client.RequestBody -- ^ The request body. + -> (ClientRequest -> ClientRequest) -- ^ Insert authentication information. + -> Signed a +signRequest m@V4{..} b auth = Signed (Meta m) (auth rq) + where + rq = (clientRequest metaEndpoint metaTimeout) + { Client.method = toBS metaMethod + , Client.path = toBS metaPath + , Client.queryString = qry + , Client.requestHeaders = metaHeaders + , Client.requestBody = b + } + + qry | BS.null x = x + | otherwise = '?' `BS8.cons` x + where + x = toBS metaCanonicalQuery + +signMetadata :: AuthEnv + -> Region + -> UTCTime + -> (Credential -> SignedHeaders -> QueryString -> QueryString) + -> Hash + -> Request a + -> V4 +signMetadata a r ts presign digest rq = V4 + { metaTime = ts + , metaMethod = method + , metaPath = path + , metaEndpoint = end + , metaCredential = cred + , metaCanonicalQuery = query + , metaCanonicalRequest = crq + , metaCanonicalHeaders = chs + , metaSignedHeaders = shs + , metaStringToSign = sts + , metaSignature = signature (_authSecret a) scope sts + , metaHeaders = _rqHeaders rq + , metaTimeout = _svcTimeout svc + } + where + query = canonicalQuery . presign cred shs $ _rqQuery rq + + sts = stringToSign ts scope crq + cred = credential (_authAccess a) scope + scope = credentialScope svc end ts + crq = canonicalRequest method path digest query chs shs + + chs = canonicalHeaders headers + shs = signedHeaders headers + headers = normaliseHeaders (_rqHeaders rq) + + end = _svcEndpoint svc r + method = Tag . toBS $ _rqMethod rq + path = escapedPath rq + + svc = _rqService rq + +algorithm :: ByteString +algorithm = "AWS4-HMAC-SHA256" + +signature :: SecretKey -> CredentialScope -> StringToSign -> Signature +signature k c = Tag . digestToBase Base16 . hmacSHA256 signingKey . unTag + where + signingKey = Fold.foldl' hmac ("AWS4" <> toBS k) (unTag c) + + hmac x y = digestToBS (hmacSHA256 x y) + +stringToSign :: UTCTime -> CredentialScope -> CanonicalRequest -> StringToSign +stringToSign t c r = Tag $ BS8.intercalate "\n" + [ algorithm + , toBS (Time t :: AWSTime) + , toBS c + , digestToBase Base16 . hashSHA256 $ toBS r + ] + +credential :: AccessKey -> CredentialScope -> Credential +credential k c = Tag (toBS k <> "/" <> toBS c) + +credentialScope :: Service -> Endpoint -> UTCTime -> CredentialScope +credentialScope s e t = Tag + [ toBS (Time t :: BasicTime) + , toBS (_endpointScope e) + , toBS (_svcPrefix s) + , "aws4_request" + ] + +canonicalRequest :: Method + -> Path + -> Hash + -> CanonicalQuery + -> CanonicalHeaders + -> SignedHeaders + -> CanonicalRequest +canonicalRequest meth path digest query chs shs = Tag $ + BS8.intercalate "\n" + [ toBS meth + , toBS path + , toBS query + , toBS chs + , toBS shs + , toBS digest + ] + +escapedPath :: Request a -> Path +escapedPath r = Tag . toBS . escapePath $ + case _svcAbbrev (_rqService r) of + "S3" -> _rqPath r + _ -> collapsePath (_rqPath r) + +canonicalQuery :: QueryString -> CanonicalQuery +canonicalQuery = Tag . toBS + +-- FIXME: the following use of stripBS is too naive, should remove +-- all internal whitespace, replacing with a single space char, +-- unless quoted with \"...\" +canonicalHeaders :: NormalisedHeaders -> CanonicalHeaders +canonicalHeaders = Tag . Fold.foldMap (uncurry f) . unTag + where + f k v = k <> ":" <> stripBS v <> "\n" + +signedHeaders :: NormalisedHeaders -> SignedHeaders +signedHeaders = Tag . BS8.intercalate ";" . map fst . unTag + +normaliseHeaders :: [Header] -> NormalisedHeaders +normaliseHeaders = Tag + . map (first CI.foldedCase) + . nubBy ((==) `on` fst) + . sortBy (compare `on` fst) + . filter ((/= "authorization") . fst) diff --git a/src/Network/AWS/Sign/V4/Chunked.hs b/src/Network/AWS/Sign/V4/Chunked.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Sign/V4/Chunked.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | +-- Module : Network.AWS.Sign.V4.Chunked +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Sign.V4.Chunked + ( chunked + ) where + +import Control.Applicative +import Control.Lens +import qualified Data.ByteString as BS +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as BS8 +import Data.Conduit +import Data.Maybe +import Data.Monoid +import Network.AWS.Data.Body +import Network.AWS.Data.ByteString +import Network.AWS.Data.Crypto +import Network.AWS.Data.Headers +import Network.AWS.Data.Time +import Network.AWS.Sign.V4.Base hiding (algorithm) +import Network.AWS.Types +import Network.HTTP.Types.Header + +import Prelude + +default (Builder, Integer) + +chunked :: ChunkedBody -> Algorithm a +chunked c rq a r ts = signRequest meta (toRequestBody body) auth + where + (meta, auth) = base (Tag digest) (prepare rq) a r ts + + prepare = rqHeaders <>~ + [ (hContentEncoding, "aws-chunked") + , (hAMZDecodedContentLength, toBS (_chunkedLength c)) + , (hContentLength, toBS (metadataLength c)) + ] + + body = Chunked (c `fuseChunks` sign (metaSignature meta)) + + sign :: Monad m => Signature -> Conduit ByteString m ByteString + sign prev = do + mx <- await + let next = chunkSignature prev (fromMaybe mempty mx) + case mx of + Nothing -> yield (chunkData next mempty) + Just x -> yield (chunkData next x) >> sign next + + chunkData next x = toBS + $ word64Hex (fromIntegral (BS.length x)) + <> byteString chunkSignatureHeader + <> byteString (toBS next) + <> byteString crlf + <> byteString x + <> byteString crlf + + chunkSignature prev x = + signature (_authSecret a) scope (chunkStringToSign prev x) + + chunkStringToSign prev x = Tag $ BS8.intercalate "\n" + [ algorithm + , time + , toBS scope + , toBS prev + , sha256Empty + , sha256 x + ] + + time :: ByteString + time = toBS (Time ts :: AWSTime) + + scope :: CredentialScope + scope = credentialScope (_rqService rq) end ts + + end :: Endpoint + end = _svcEndpoint (_rqService rq) r + +metadataLength :: ChunkedBody -> Integer +metadataLength c = + -- Number of full sized chunks. + fullChunks c * chunkLength (_chunkedSize c) + -- Non-full chunk preceeding the final chunk. + + maybe 0 chunkLength (remainderBytes c) + -- The final empty chunk. + + chunkLength 0 + where + chunkLength :: Integral a => a -> Integer + chunkLength (toInteger -> n) = + _chunkedLength c + + headerLength + + signatureLength + + crlfLength + + n + + crlfLength + + headerLength = toInteger (BS.length chunkSignatureHeader) + crlfLength = toInteger (BS.length crlf) + signatureLength = 64 + +sha256 :: ByteString -> ByteString +sha256 = digestToBase Base16 . hashSHA256 + +sha256Empty :: ByteString +sha256Empty = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" + +algorithm :: ByteString +algorithm = "AWS4-HMAC-SHA256-PAYLOAD" + +digest :: ByteString +digest = "STREAMING-AWS4-HMAC-SHA256-PAYLOAD" + +chunkSignatureHeader :: ByteString +chunkSignatureHeader = ";chunk-signature=" + +crlf :: ByteString +crlf = "\r\n" diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs --- a/src/Network/AWS/Types.hs +++ b/src/Network/AWS/Types.hs @@ -151,8 +151,8 @@ import Network.AWS.Data.Query import Network.AWS.Data.Text import Network.AWS.Data.XML -import Network.HTTP.Client hiding (Proxy, Request, Response) -import qualified Network.HTTP.Client as Client +import Network.HTTP.Conduit hiding (Proxy, Request, Response) +import qualified Network.HTTP.Conduit as Client import Network.HTTP.Types.Header import Network.HTTP.Types.Method import Network.HTTP.Types.Status (Status) @@ -494,7 +494,7 @@ response :: MonadResource m => Logger -> Service - -> Proxy a + -> Proxy a -- For injectivity reasons. -> ClientResponse -> m (Response a)