git.iko.soy/typeable/minio-hs
on master help sign in
Add streaming signature for PutObject (#123)

Use streaming signature to avoid reading the body twice in PutObject requests, where the body can be upto 5GIB. Note that the body is signed only used when the connection is not using TLS.

commit4a807fde569f134921304242ec134405836c1a76 authorAditya Manthramurthy <donatello@users.noreply.github.com> dateThu 16 May 2019, 20:49 (7 years ago) parent909f1c4
9 files changed+347−154
compare with master
unifiedsplit
minio-hs.cabal+9−9 src/Network/Minio/API.hs+87−64 src/Network/Minio/APICommon.hs+25−1 src/Network/Minio/Data.hs+5−4 src/Network/Minio/Errors.hs+3−1 src/Network/Minio/PutObject.hs+8−8 src/Network/Minio/S3API.hs+19−14 src/Network/Minio/Sign/V4.hs+178−35 src/Network/Minio/Utils.hs+13−18
minio-hs.cabal+9−9
@@ -116,15 +116,18 @@ test-suite minio-hs-live-server-test
116116 , TypeFamilies
117117 other-modules: Lib.Prelude
118118 , Network.Minio
119− , Network.Minio.AdminAPI
120119 , Network.Minio.API
120+ , Network.Minio.API.Test
121121 , Network.Minio.APICommon
122+ , Network.Minio.AdminAPI
122123 , Network.Minio.CopyObject
123124 , Network.Minio.Data
124125 , Network.Minio.Data.ByteString
125126 , Network.Minio.Data.Crypto
126127 , Network.Minio.Data.Time
127128 , Network.Minio.Errors
129+ , Network.Minio.JsonParser
130+ , Network.Minio.JsonParser.Test
128131 , Network.Minio.ListOps
129132 , Network.Minio.PresignedOperations
130133 , Network.Minio.PutObject
@@ -134,13 +137,10 @@ test-suite minio-hs-live-server-test
134137 , Network.Minio.TestHelpers
135138 , Network.Minio.Utils
136139 , Network.Minio.Utils.Test
137− , Network.Minio.API.Test
138140 , Network.Minio.XmlGenerator
139141 , Network.Minio.XmlGenerator.Test
140142 , Network.Minio.XmlParser
141143 , Network.Minio.XmlParser.Test
142− , Network.Minio.JsonParser
143− , Network.Minio.JsonParser.Test
144144 build-depends: base >= 4.7 && < 5
145145 , minio-hs
146146 , protolude >= 0.1.6
@@ -243,15 +243,18 @@ test-suite minio-hs-test
243243 , TypeFamilies
244244 other-modules: Lib.Prelude
245245 , Network.Minio
246− , Network.Minio.AdminAPI
247246 , Network.Minio.API
247+ , Network.Minio.API.Test
248248 , Network.Minio.APICommon
249+ , Network.Minio.AdminAPI
250+ , Network.Minio.CopyObject
249251 , Network.Minio.Data
250252 , Network.Minio.Data.ByteString
251253 , Network.Minio.Data.Crypto
252254 , Network.Minio.Data.Time
253− , Network.Minio.CopyObject
254255 , Network.Minio.Errors
256+ , Network.Minio.JsonParser
257+ , Network.Minio.JsonParser.Test
255258 , Network.Minio.ListOps
256259 , Network.Minio.PresignedOperations
257260 , Network.Minio.PutObject
@@ -261,13 +264,10 @@ test-suite minio-hs-test
261264 , Network.Minio.TestHelpers
262265 , Network.Minio.Utils
263266 , Network.Minio.Utils.Test
264− , Network.Minio.API.Test
265267 , Network.Minio.XmlGenerator
266268 , Network.Minio.XmlGenerator.Test
267269 , Network.Minio.XmlParser
268270 , Network.Minio.XmlParser.Test
269− , Network.Minio.JsonParser
270− , Network.Minio.JsonParser.Test
271271
272272source-repository head
273273 type: git
src/Network/Minio/API.hs+87−64
@@ -37,7 +37,6 @@ import qualified Data.Conduit as C
3737import qualified Data.Map as Map
3838import qualified Data.Text as T
3939import qualified Data.Time.Clock as Time
40−
4140import Network.HTTP.Conduit (Response)
4241import qualified Network.HTTP.Conduit as NC
4342import qualified Network.HTTP.Types as HT
@@ -75,73 +74,97 @@ discoverRegion ri = runMaybeT $ do
7574 return l
7675 ) return regionMay
7776
77+getRegion :: S3ReqInfo -> Minio (Maybe Region)
78+getRegion ri = do
79+ ci <- asks mcConnInfo
80+
81+ -- getService/makeBucket/getLocation -- don't need location
82+ if | not $ riNeedsLocation ri ->
83+ return $ Just $ connectRegion ci
84+
85+ -- if autodiscovery of location is disabled by user
86+ | not $ connectAutoDiscoverRegion ci ->
87+ return $ Just $ connectRegion ci
88+
89+ -- discover the region for the request
90+ | otherwise -> discoverRegion ri
91+
92+getRegionHost :: Region -> Minio Text
93+getRegionHost r = do
94+ ci <- asks mcConnInfo
95+
96+ if "amazonaws.com" `T.isSuffixOf` connectHost ci
97+ then maybe (throwIO $ MErrVRegionNotSupported r)
98+ return (Map.lookup r awsRegionMap)
99+ else return $ connectHost ci
78100
79101buildRequest :: S3ReqInfo -> Minio NC.Request
80102buildRequest ri = do
81− maybe (return ()) checkBucketNameValidity $ riBucket ri
82− maybe (return ()) checkObjectNameValidity $ riObject ri
83−
84− ci <- asks mcConnInfo
85−
86− -- getService/makeBucket/getLocation -- don't need
87− -- location
88− region <- if | not $ riNeedsLocation ri ->
89− return $ Just $ connectRegion ci
90−
91− -- if autodiscovery of location is disabled by user
92− | not $ connectAutoDiscoverRegion ci ->
93− return $ Just $ connectRegion ci
94−
95− -- discover the region for the request
96− | otherwise -> discoverRegion ri
97−
98− regionHost <- case region of
99− Nothing -> return $ connectHost ci
100− Just r -> if "amazonaws.com" `T.isSuffixOf` connectHost ci
101− then maybe
102− (throwIO $ MErrVRegionNotSupported r)
103− return
104− (Map.lookup r awsRegionMap)
105− else return $ connectHost ci
106−
107− sha256Hash <- if | connectIsSecure ci ->
108− -- if secure connection
109− return "UNSIGNED-PAYLOAD"
110−
111− -- otherwise compute sha256
112− | otherwise -> getPayloadSHA256Hash (riPayload ri)
113−
114− timeStamp <- liftIO Time.getCurrentTime
115−
116− let hostHeader = (hHost, getHostAddr ci)
117− newRi = ri { riPayloadHash = Just sha256Hash
118− , riHeaders = hostHeader
119− : sha256Header sha256Hash
120− : riHeaders ri
121− , riRegion = region
103+ maybe (return ()) checkBucketNameValidity $ riBucket ri
104+ maybe (return ()) checkObjectNameValidity $ riObject ri
105+
106+ ci <- asks mcConnInfo
107+
108+ regionMay <- getRegion ri
109+
110+ regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay
111+
112+ let ri' = ri { riHeaders = hostHeader : riHeaders ri
113+ , riRegion = regionMay
122114 }
123− newCi = ci { connectHost = regionHost }
124− signReq = toRequest newCi newRi
125− sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
126− timeStamp (riRegion newRi) Nothing (riPayloadHash newRi)
127− let signHeaders = signV4 sp signReq
128−
129− -- Update signReq with Authorization header containing v4 signature
130− return signReq {
131− NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders
132− }
133− where
134− toRequest :: ConnectInfo -> S3ReqInfo -> NC.Request
135− toRequest ci s3Req = NC.defaultRequest {
136− NC.method = riMethod s3Req
137− , NC.secure = connectIsSecure ci
138− , NC.host = encodeUtf8 $ connectHost ci
139− , NC.port = connectPort ci
140− , NC.path = getS3Path (riBucket s3Req) (riObject s3Req)
141− , NC.requestHeaders = riHeaders s3Req
142− , NC.queryString = HT.renderQuery False $ riQueryParams s3Req
143− , NC.requestBody = getRequestBody (riPayload s3Req)
144− }
115+ ci' = ci { connectHost = regionHost }
116+ hostHeader = (hHost, getHostAddr ci')
117+
118+ -- Does not contain body and auth info.
119+ baseRequest = NC.defaultRequest
120+ { NC.method = riMethod ri'
121+ , NC.secure = connectIsSecure ci'
122+ , NC.host = encodeUtf8 $ connectHost ci'
123+ , NC.port = connectPort ci'
124+ , NC.path = getS3Path (riBucket ri') (riObject ri')
125+ , NC.requestHeaders = riHeaders ri'
126+ , NC.queryString = HT.renderQuery False $ riQueryParams ri'
127+ }
128+
129+ timeStamp <- liftIO Time.getCurrentTime
130+
131+ let sp = SignParams (connectAccessKey ci') (connectSecretKey ci')
132+ timeStamp (riRegion ri') Nothing Nothing
133+
134+ -- Cases to handle:
135+ --
136+ -- 1. Connection is secure: use unsigned payload
137+ --
138+ -- 2. Insecure connection, streaming signature is enabled via use of
139+ -- conduit payload: use streaming signature for request.
140+ --
141+ -- 3. Insecure connection, non-conduit payload: compute payload
142+ -- sha256hash, buffer request in memory and perform request.
143+
144+ -- case 2 from above.
145+ if | isStreamingPayload (riPayload ri') &&
146+ (not $ connectIsSecure ci') -> do
147+ (pLen, pSrc) <- case riPayload ri of
148+ PayloadC l src -> return (l, src)
149+ _ -> throwIO MErrVUnexpectedPayload
150+ let reqFn = signV4Stream pLen sp baseRequest
151+ return $ reqFn pSrc
152+
153+ | otherwise -> do
154+ -- case 1 described above.
155+ sp' <- if | connectIsSecure ci' -> return sp
156+ -- case 3 described above.
157+ | otherwise -> do
158+ pHash <- getPayloadSHA256Hash $ riPayload ri'
159+ return $ sp { spPayloadHash = Just pHash }
160+
161+ let signHeaders = signV4 sp' baseRequest
162+ return $ baseRequest
163+ { NC.requestHeaders =
164+ NC.requestHeaders baseRequest ++
165+ mkHeaderFromPairs signHeaders
166+ , NC.requestBody = getRequestBody (riPayload ri')
167+ }
145168
146169
147170retryAPIRequest :: Minio a -> Minio a
src/Network/Minio/APICommon.hs+25−1
@@ -16,6 +16,9 @@
1616
1717module Network.Minio.APICommon where
1818
19+import qualified Conduit as C
20+import qualified Data.ByteString as BS
21+import qualified Data.ByteString.Lazy as LB
1922import Data.Conduit.Binary (sourceHandleRange)
2023import qualified Network.HTTP.Conduit as NC
2124import qualified Network.HTTP.Types as HT
@@ -24,16 +27,20 @@ import Lib.Prelude
2427
2528import Network.Minio.Data
2629import Network.Minio.Data.Crypto
30+import Network.Minio.Errors
2731
2832sha256Header :: ByteString -> HT.Header
2933sha256Header = ("x-amz-content-sha256", )
3034
31−getPayloadSHA256Hash :: (MonadIO m) => Payload -> m ByteString
35+-- | This function throws an error if the payload is a conduit (as it
36+-- will not be possible to re-read the conduit after it is consumed).
37+getPayloadSHA256Hash :: Payload -> Minio ByteString
3238getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs
3339getPayloadSHA256Hash (PayloadH h off size) = hashSHA256FromSource $
3440 sourceHandleRange h
3541 (return . fromIntegral $ off)
3642 (return . fromIntegral $ size)
43+getPayloadSHA256Hash (PayloadC _ _) = throwIO MErrVUnexpectedPayload
3744
3845getRequestBody :: Payload -> NC.RequestBody
3946getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs
@@ -42,3 +49,20 @@ getRequestBody (PayloadH h off size) =
4249 sourceHandleRange h
4350 (return . fromIntegral $ off)
4451 (return . fromIntegral $ size)
52+getRequestBody (PayloadC n src) = NC.requestBodySource n src
53+
54+mkStreamingPayload :: Payload -> Payload
55+mkStreamingPayload payload =
56+ case payload of
57+ PayloadBS bs ->
58+ PayloadC (fromIntegral $ BS.length bs)
59+ (C.sourceLazy $ LB.fromStrict bs)
60+ PayloadH h off len ->
61+ PayloadC len $ sourceHandleRange h
62+ (return . fromIntegral $ off)
63+ (return . fromIntegral $ len)
64+ _ -> payload
65+
66+isStreamingPayload :: Payload -> Bool
67+isStreamingPayload (PayloadC _ _) = True
68+isStreamingPayload _ = False
src/Network/Minio/Data.hs+5−4
@@ -20,6 +20,7 @@
2020{-# LANGUAGE TypeFamilies #-}
2121module Network.Minio.Data where
2222
23+import qualified Conduit as C
2324import Control.Concurrent.MVar (MVar)
2425import qualified Control.Concurrent.MVar as M
2526import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..),
@@ -883,10 +884,10 @@ type Stats = Progress
883884
884885-- | Represents different kinds of payload that are used with S3 API
885886-- requests.
886−data Payload = PayloadBS ByteString
887− | PayloadH Handle
888− Int64 -- offset
889− Int64 -- size
887+data Payload
888+ = PayloadBS ByteString
889+ | PayloadH Handle Int64 Int64 -- file handle, offset and length
890+ | PayloadC Int64 (C.ConduitT () ByteString (ResourceT IO) ()) -- length and byte source
890891
891892defaultPayload :: Payload
892893defaultPayload = PayloadBS ""
src/Network/Minio/Errors.hs+3−1
@@ -1,5 +1,5 @@
11--
2−-- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
2+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
33--
44-- Licensed under the Apache License, Version 2.0 (the "License");
55-- you may not use this file except in compliance with the License.
@@ -42,6 +42,8 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
4242 | MErrVInvalidHealPath
4343 | MErrVMissingCredentials
4444 | MErrVInvalidEncryptionKeyLength
45+ | MErrVStreamingBodyUnexpectedEOF
46+ | MErrVUnexpectedPayload
4547 deriving (Show, Eq)
4648
4749instance Exception MErrV
src/Network/Minio/PutObject.hs+8−8
@@ -1,5 +1,5 @@
11--
2−-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
2+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
33--
44-- Licensed under the Apache License, Version 2.0 (the "License");
55-- you may not use this file except in compliance with the License.
@@ -23,13 +23,14 @@ module Network.Minio.PutObject
2323
2424
2525import Conduit (takeC)
26+import qualified Conduit as C
2627import qualified Data.ByteString.Lazy as LBS
27−import qualified Data.Conduit as C
2828import qualified Data.Conduit.Binary as CB
2929import qualified Data.Conduit.Combinators as CC
3030import qualified Data.Conduit.List as CL
3131import qualified Data.List as List
3232
33+
3334import Lib.Prelude
3435
3536import Network.Minio.Data
@@ -63,8 +64,8 @@ putObjectInternal :: Bucket -> Object -> PutObjectOptions
6364 -> ObjectData Minio -> Minio ETag
6465putObjectInternal b o opts (ODStream src sizeMay) = do
6566 case sizeMay of
66− -- unable to get size, so assume non-seekable file and max-object size
67− Nothing -> sequentialMultipartUpload b o opts (Just maxObjectSize) src
67+ -- unable to get size, so assume non-seekable file
68+ Nothing -> sequentialMultipartUpload b o opts Nothing src
6869
6970 -- got file size, so check for single/multipart upload
7071 Just size ->
@@ -85,9 +86,8 @@ putObjectInternal b o opts (ODFile fp sizeMay) = do
8586 let finalSizeMay = listToMaybe $ catMaybes [sizeMay, handleSizeMay]
8687
8788 case finalSizeMay of
88− -- unable to get size, so assume non-seekable file and max-object size
89− Nothing -> sequentialMultipartUpload b o opts (Just maxObjectSize) $
90− CB.sourceFile fp
89+ -- unable to get size, so assume non-seekable file
90+ Nothing -> sequentialMultipartUpload b o opts Nothing $ CB.sourceFile fp
9191
9292 -- got file size, so check for single/multipart upload
9393 Just size ->
@@ -138,7 +138,7 @@ sequentialMultipartUpload b o opts sizeMay src = do
138138 (pnums, _, sizes) = List.unzip3 partSizes
139139 uploadedParts <- C.runConduit
140140 $ src
141− C..| chunkBSConduit sizes
141+ C..| chunkBSConduit (map fromIntegral sizes)
142142 C..| CL.map PayloadBS
143143 C..| uploadPart' uploadId pnums
144144 C..| CC.sinkList
src/Network/Minio/S3API.hs+19−14
@@ -42,6 +42,7 @@ module Network.Minio.S3API
4242 ---------------------------------
4343 , putBucket
4444 , ETag
45+ , maxSinglePutObjectSizeBytes
4546 , putObjectSingle'
4647 , putObjectSingle
4748 , copyObjectSingle
@@ -90,8 +91,8 @@ module Network.Minio.S3API
9091 , removeAllBucketNotification
9192 ) where
9293
94+import qualified Conduit as C
9395import qualified Data.ByteString as BS
94−import qualified Data.Conduit as C
9596import qualified Data.Text as T
9697import qualified Network.HTTP.Conduit as NC
9798import qualified Network.HTTP.Types as HT
@@ -101,6 +102,7 @@ import UnliftIO (Handler (Handler))
101102import Lib.Prelude
102103
103104import Network.Minio.API
105+import Network.Minio.APICommon
104106import Network.Minio.Data
105107import Network.Minio.Errors
106108import Network.Minio.PresignedOperations
@@ -156,13 +158,13 @@ putObjectSingle' bucket object headers bs = do
156158 when (size > maxSinglePutObjectSizeBytes) $
157159 throwIO $ MErrVSinglePUTSizeExceeded size
158160
159− -- content-length header is automatically set by library.
161+ let payload = mkStreamingPayload $ PayloadBS bs
160162 resp <- executeRequest $
161163 defaultS3ReqInfo { riMethod = HT.methodPut
162164 , riBucket = Just bucket
163165 , riObject = Just object
164166 , riHeaders = headers
165− , riPayload = PayloadBS bs
167+ , riPayload = payload
166168 }
167169
168170 let rheaders = NC.responseHeaders resp
@@ -181,13 +183,14 @@ putObjectSingle bucket object headers h offset size = do
181183 throwIO $ MErrVSinglePUTSizeExceeded size
182184
183185 -- content-length header is automatically set by library.
186+ let payload = mkStreamingPayload $ PayloadH h offset size
184187 resp <- executeRequest $
185188 defaultS3ReqInfo { riMethod = HT.methodPut
186− , riBucket = Just bucket
187− , riObject = Just object
188− , riHeaders = headers
189− , riPayload = PayloadH h offset size
190− }
189+ , riBucket = Just bucket
190+ , riObject = Just object
191+ , riHeaders = headers
192+ , riPayload = payload
193+ }
191194
192195 let rheaders = NC.responseHeaders resp
193196 etag = getETagHeader rheaders
@@ -264,14 +267,16 @@ newMultipartUpload bucket object headers = do
264267putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header]
265268 -> Payload -> Minio PartTuple
266269putObjectPart bucket object uploadId partNumber headers payload = do
270+ -- transform payload to conduit to enable streaming signature
271+ let payload' = mkStreamingPayload payload
267272 resp <- executeRequest $
268273 defaultS3ReqInfo { riMethod = HT.methodPut
269− , riBucket = Just bucket
270− , riObject = Just object
271− , riQueryParams = mkOptionalParams params
272− , riHeaders = headers
273− , riPayload = payload
274− }
274+ , riBucket = Just bucket
275+ , riObject = Just object
276+ , riQueryParams = mkOptionalParams params
277+ , riHeaders = headers
278+ , riPayload = payload'
279+ }
275280 let rheaders = NC.responseHeaders resp
276281 etag = getETagHeader rheaders
277282 maybe
src/Network/Minio/Sign/V4.hs+178−35
@@ -1,5 +1,5 @@
11--
2−-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
2+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
33--
44-- Licensed under the Apache License, Version 2.0 (the "License");
55-- you may not use this file except in compliance with the License.
@@ -14,21 +14,9 @@
1414-- limitations under the License.
1515--
1616
17−module Network.Minio.Sign.V4
18− (
19− signV4
20− , signV4PostPolicy
21− , mkScope
22− , getHeadersToSign
23− , mkCanonicalRequest
24− , mkStringToSign
25− , mkSigningKey
26− , computeSignature
27− , SignV4Data(..)
28− , SignParams(..)
29− , debugPrintSignV4Data
30− ) where
17+module Network.Minio.Sign.V4 where
3118
19+import qualified Conduit as C
3220import qualified Data.ByteString as B
3321import qualified Data.ByteString.Base64 as Base64
3422import qualified Data.ByteString.Char8 as B8
@@ -39,13 +27,15 @@ import qualified Data.Set as Set
3927import qualified Data.Time as Time
4028import qualified Network.HTTP.Conduit as NC
4129import Network.HTTP.Types (Header, parseQuery)
42−import qualified Network.HTTP.Types.Header as H
30+import qualified Network.HTTP.Types as H
31+import Text.Printf (printf)
4332
4433import Lib.Prelude
4534
4635import Network.Minio.Data.ByteString
4736import Network.Minio.Data.Crypto
4837import Network.Minio.Data.Time
38+import Network.Minio.Errors
4939
5040-- these headers are not included in the string to sign when signing a
5141-- request
@@ -53,7 +43,6 @@ ignoredHeaders :: Set ByteString
5343ignoredHeaders = Set.fromList $ map CI.foldedCase
5444 [ H.hAuthorization
5545 , H.hContentType
56− , H.hContentLength
5746 , H.hUserAgent
5847 ]
5948
@@ -93,6 +82,20 @@ debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
9382 mapM_ (\x -> B.putStr $ B.concat [show x, " "]) $ B.unpack b
9483 B8.putStrLn ""
9584
85+mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
86+mkAuthHeader accessKey scope signedHeaderKeys sign =
87+ let authValue = B.concat
88+ [ "AWS4-HMAC-SHA256 Credential="
89+ , toS accessKey
90+ , "/"
91+ , scope
92+ , ", SignedHeaders="
93+ , signedHeaderKeys
94+ , ", Signature="
95+ , sign
96+ ]
97+ in (H.hAuthorization, authValue)
98+
9699-- | Given SignParams and request details, including request method,
97100-- request path, headers, query params and payload hash, generates an
98101-- updated set of headers, including the x-amz-date header and the
@@ -105,7 +108,6 @@ debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
105108-- is being created. The expiry is interpreted as an integer number of
106109-- seconds. The output will be the list of query-parameters to add to
107110-- the request.
108−
109111signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]
110112signV4 !sp !req =
111113 let
@@ -139,7 +141,8 @@ signV4 !sp !req =
139141 else []
140142
141143 -- 1. compute canonical request
142− canonicalRequest = mkCanonicalRequest sp (NC.setQueryString finalQP req)
144+ canonicalRequest = mkCanonicalRequest False sp
145+ (NC.setQueryString finalQP req)
143146 headersToSign
144147
145148 -- 2. compute string to sign
@@ -152,23 +155,15 @@ signV4 !sp !req =
152155 signature = computeSignature stringToSign signingKey
153156
154157 -- 4. compute auth header
155− authValue = B.concat
156− [ "AWS4-HMAC-SHA256 Credential="
157− , accessKey
158− , "/"
159− , scope
160− , ", SignedHeaders="
161− , signedHeaderKeys
162− , ", Signature="
163− , signature
164− ]
165− authHeader = (H.hAuthorization, authValue)
158+ authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature
166159
167160 -- finally compute output pairs
161+ sha256Hdr = ("x-amz-content-sha256",
162+ fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp)
168163 output = if isJust expiry
169164 then ("X-Amz-Signature", signature) : authQP
170165 else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,
171− datePair]
166+ datePair, sha256Hdr]
172167
173168 in output
174169
@@ -186,9 +181,9 @@ getHeadersToSign !h =
186181 filter (flip Set.notMember ignoredHeaders . fst) $
187182 map (\(x, y) -> (CI.foldedCase x, stripBS y)) h
188183
189−mkCanonicalRequest :: SignParams -> NC.Request -> [(ByteString, ByteString)]
190− -> ByteString
191−mkCanonicalRequest !sp !req !headersForSign =
184+mkCanonicalRequest :: Bool -> SignParams -> NC.Request -> [(ByteString, ByteString)]
185+ -> ByteString
186+mkCanonicalRequest !isStreaming !sp !req !headersForSign =
192187 let
193188 canonicalQueryString = B.intercalate "&" $
194189 map (\(x, y) -> B.concat [x, "=", y]) $
@@ -203,6 +198,10 @@ mkCanonicalRequest !sp !req !headersForSign =
203198
204199 signedHeaders = B.intercalate ";" $ map fst sortedHeaders
205200
201+ payloadHashStr =
202+ if isStreaming
203+ then "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
204+ else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
206205 in
207206 B.intercalate "\n"
208207 [ NC.method req
@@ -210,7 +209,7 @@ mkCanonicalRequest !sp !req !headersForSign =
210209 , canonicalQueryString
211210 , canonicalHeaders
212211 , signedHeaders
213− , maybe "UNSIGNED-PAYLOAD" identity $ spPayloadHash sp
212+ , payloadHashStr
214213 ]
215214
216215mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
@@ -246,3 +245,147 @@ signV4PostPolicy !postPolicyJSON !sp =
246245 Map.fromList [ ("x-amz-signature", signature)
247246 , ("policy", stringToSign)
248247 ]
248+
249+chunkSizeConstant :: Int
250+chunkSizeConstant = 64 * 1024
251+
252+-- base16Len computes the number of bytes required to represent @n (> 0)@ in
253+-- hexadecimal.
254+base16Len :: Integral a => a -> Int
255+base16Len n | n == 0 = 0
256+ | otherwise = 1 + base16Len (n `div` 16)
257+
258+signedStreamLength :: Int64 -> Int64
259+signedStreamLength dataLen =
260+ let
261+ chunkSzInt = fromIntegral chunkSizeConstant
262+ (numChunks, lastChunkLen) = quotRem dataLen chunkSzInt
263+
264+
265+ -- Structure of a chunk:
266+ -- string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n
267+ encodedChunkLen csz = fromIntegral (base16Len csz) + 17 + 64 + 2 + csz + 2
268+ fullChunkSize = encodedChunkLen chunkSzInt
269+ lastChunkSize = bool 0 (encodedChunkLen lastChunkLen) $ lastChunkLen > 0
270+ finalChunkSize = 1 + 17 + 64 + 2 + 2
271+ in
272+ numChunks * fullChunkSize + lastChunkSize + finalChunkSize
273+
274+signV4Stream :: Int64 -> SignParams -> NC.Request
275+ -> (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
276+ -- -> ([Header], C.ConduitT () ByteString (C.ResourceT IO) () -> NC.RequestBody)
277+signV4Stream !payloadLength !sp !req =
278+ let
279+ ts = spTimeStamp sp
280+
281+ addContentEncoding hs =
282+ let ceMay = headMay $ filter (\(x, _) -> x == "content-encoding") hs
283+ in case ceMay of
284+ Nothing -> ("content-encoding", "aws-chunked") : hs
285+ Just (_, ce) -> ("content-encoding", ce <> ",aws-chunked") :
286+ filter (\(x, _) -> x /= "content-encoding") hs
287+
288+ -- headers to be added to the request
289+ datePair = ("X-Amz-Date", awsTimeFormatBS ts)
290+ computedHeaders = addContentEncoding $
291+ datePair : NC.requestHeaders req
292+
293+ -- headers specific to streaming signature
294+ signedContentLength = signedStreamLength payloadLength
295+ streamingHeaders :: [Header]
296+ streamingHeaders =
297+ [ ("x-amz-decoded-content-length", show payloadLength)
298+ , ("content-length", show signedContentLength )
299+ , ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
300+ ]
301+ headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders
302+ signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
303+ finalQP = parseQuery (NC.queryString req)
304+
305+ -- 1. Compute Seed Signature
306+ -- 1.1 Canonical Request
307+ canonicalReq = mkCanonicalRequest True sp
308+ (NC.setQueryString finalQP req)
309+ headersToSign
310+
311+ region = fromMaybe "" $ spRegion sp
312+ scope = mkScope ts region
313+ accessKey = spAccessKey sp
314+ secretKey = spSecretKey sp
315+
316+ -- 1.2 String toSign
317+ stringToSign = mkStringToSign ts scope canonicalReq
318+
319+ -- 1.3 Compute signature
320+ -- 1.3.1 compute signing key
321+ signingKey = mkSigningKey ts region $ toS secretKey
322+
323+ -- 1.3.2 Compute signature
324+ seedSignature = computeSignature stringToSign signingKey
325+
326+ -- 1.3.3 Compute Auth Header
327+ authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature
328+
329+ -- 1.4 Updated headers for the request
330+ finalReqHeaders = authHeader : (computedHeaders ++ streamingHeaders)
331+ -- headersToAdd = authHeader : datePair : streamingHeaders
332+
333+ toHexStr n = B8.pack $ printf "%x" n
334+
335+ (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant
336+
337+ -- Function to compute string to sign for each chunk.
338+ chunkStrToSign prevSign currChunkHash =
339+ B.intercalate "\n"
340+ [ "AWS4-HMAC-SHA256-PAYLOAD"
341+ , awsTimeFormatBS ts
342+ , scope
343+ , prevSign
344+ , hashSHA256 ""
345+ , currChunkHash
346+ ]
347+
348+ -- Read n byte from upstream and return a strict bytestring.
349+ mustTakeN n = do
350+ bs <- toS <$> (C.takeCE n C..| C.sinkLazy)
351+ when (B.length bs /= n) $
352+ throwIO MErrVStreamingBodyUnexpectedEOF
353+ return bs
354+
355+ signerConduit n lps prevSign =
356+ -- First case encodes a full chunk of length
357+ -- 'chunkSizeConstant'.
358+ if | n > 0 -> do
359+ bs <- mustTakeN chunkSizeConstant
360+ let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
361+ nextSign = computeSignature strToSign signingKey
362+ chunkBS = toHexStr chunkSizeConstant
363+ <> ";chunk-signature="
364+ <> nextSign <> "\r\n" <> bs <> "\r\n"
365+ C.yield chunkBS
366+ signerConduit (n-1) lps nextSign
367+
368+ -- Second case encodes the last chunk which is smaller than
369+ -- 'chunkSizeConstant'
370+ | lps > 0 -> do
371+ bs <- mustTakeN $ fromIntegral lps
372+ let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
373+ nextSign = computeSignature strToSign signingKey
374+ chunkBS = toHexStr lps <> ";chunk-signature="
375+ <> nextSign <> "\r\n" <> bs <> "\r\n"
376+ C.yield chunkBS
377+ signerConduit 0 0 nextSign
378+
379+ -- Last case encodes the final signature chunk that has no
380+ -- data.
381+ | otherwise -> do
382+ let strToSign = chunkStrToSign prevSign (hashSHA256 "")
383+ nextSign = computeSignature strToSign signingKey
384+ lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"
385+ C.yield lastChunkBS
386+ in
387+ \src -> req { NC.requestHeaders = finalReqHeaders
388+ , NC.requestBody =
389+ NC.requestBodySource signedContentLength $
390+ src C..| signerConduit numParts lastPSize seedSignature
391+ }
src/Network/Minio/Utils.hs+13−18
@@ -1,5 +1,5 @@
11--
2−-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
2+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
33--
44-- Licensed under the Apache License, Version 2.0 (the "License");
55-- you may not use this file except in compliance with the License.
@@ -16,12 +16,12 @@
1616
1717module Network.Minio.Utils where
1818
19+import qualified Conduit as C
1920import Control.Monad.IO.Unlift (MonadUnliftIO)
2021import qualified Control.Monad.Trans.Resource as R
2122import qualified Data.ByteString as B
2223import qualified Data.ByteString.Lazy as LB
2324import Data.CaseInsensitive (mk, original)
24−import qualified Data.Conduit as C
2525import qualified Data.Conduit.Binary as CB
2626import qualified Data.List as List
2727import qualified Data.Map as Map
@@ -212,22 +212,17 @@ mkQuery k mv = (k,) <$> mv
212212mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query
213213mkOptionalParams params = HT.toQuery $ uncurry mkQuery <$> params
214214
215−chunkBSConduit :: (Monad m, Integral a)
216− => [a] -> C.ConduitM ByteString ByteString m ()
217−chunkBSConduit s = loop 0 [] s
218− where
219− loop _ _ [] = return ()
220− loop n readChunks (size:sizes) = do
221− bsMay <- C.await
222− case bsMay of
223− Nothing -> when (n > 0) $ C.yield $ B.concat readChunks
224− Just bs -> if n + fromIntegral (B.length bs) >= size
225− then do let (a, b) = B.splitAt (fromIntegral $ size - n) bs
226− chunkBS = B.concat $ readChunks ++ [a]
227− C.yield chunkBS
228− loop (fromIntegral $ B.length b) [b] sizes
229− else loop (n + fromIntegral (B.length bs))
230− (readChunks ++ [bs]) (size:sizes)
215+-- | Conduit that rechunks bytestrings into the given chunk
216+-- lengths. Stops after given chunk lengths are yielded. Stops if
217+-- there are no more chunks to yield or if a shorter chunk is
218+-- received. Does not throw any errors.
219+chunkBSConduit :: (Monad m) => [Int] -> C.ConduitM ByteString ByteString m ()
220+chunkBSConduit [] = return ()
221+chunkBSConduit (s:ss) = do
222+ bs <- fmap LB.toStrict $ C.takeCE s C..| C.sinkLazy
223+ if | B.length bs == s -> C.yield bs >> chunkBSConduit ss
224+ | B.length bs > 0 -> C.yield bs
225+ | otherwise -> return ()
231226
232227-- | Select part sizes - the logic is that the minimum part-size will
233228-- be 64MiB.