amazonka-core 1.3.1 → 1.3.2

raw patch · 12 files changed

+643/−326 lines, 12 filesdep +http-conduitdep −http-clientdep ~conduitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-conduit

Dependencies removed: http-client

Dependency ranges changed: conduit

API changes (from Hackage documentation)

Files

• amazonka-core.cabal +6/−2
• src/Network/AWS/Data/Body.hs +174/−50
• src/Network/AWS/Data/Headers.hs +7/−0
• src/Network/AWS/Data/Log.hs +1/−1
• src/Network/AWS/Error.hs +1/−1
• src/Network/AWS/Request.hs +7/−16
• src/Network/AWS/Response.hs +2/−2
• src/Network/AWS/Sign/V2.hs +7/−7
• src/Network/AWS/Sign/V4.hs +30/−244
• src/Network/AWS/Sign/V4/Base.hs +269/−0
• src/Network/AWS/Sign/V4/Chunked.hs +136/−0
• src/Network/AWS/Types.hs +3/−3

@@ -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

@@ -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)

@@ -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"

@@ -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 

@@ -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

@@ -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 =

@@ -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

@@ -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

@@ -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

@@ -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 <brendan.g.hay@gmail.com>+-- 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)

@@ -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 <brendan.g.hay@gmail.com>+-- 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"

@@ -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)