Add presigned operations APIs (#56)
This change adds 3 functions to main API: presignedGetObjectURL, presignedPutObjectURL and presignedHeadObjectURL. A fourth more generic API is added to `Network.Minio.S3API` - makePresignedURL. Additionally, refactors signing code for readability and the ability to reuse for pre-signing.
This commit is contained in:
Aditya Manthramurthy
Krishnan Parthasarathi
parent
d7ba361784
commit
02170778da
@ -65,6 +65,7 @@ library
|
||||
default-language: Haskell2010
|
||||
default-extensions: FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, BangPatterns
|
||||
, MultiParamTypeClasses
|
||||
, MultiWayIf
|
||||
, NoImplicitPrelude
|
||||
@ -84,7 +85,8 @@ test-suite minio-hs-live-server-test
|
||||
main-is: LiveServer.hs
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
default-language: Haskell2010
|
||||
default-extensions: FlexibleContexts
|
||||
default-extensions: BangPatterns
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, OverloadedStrings
|
||||
, NoImplicitPrelude
|
||||
@ -194,7 +196,8 @@ test-suite minio-hs-test
|
||||
, xml-conduit
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
default-language: Haskell2010
|
||||
default-extensions: FlexibleContexts
|
||||
default-extensions: BangPatterns
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, OverloadedStrings
|
||||
, NoImplicitPrelude
|
||||
|
||||
@ -14,17 +14,12 @@
|
||||
-- limitations under the License.
|
||||
--
|
||||
|
||||
{-
|
||||
Welcome to your custom Prelude
|
||||
Export here everything that should always be in your library scope
|
||||
For more info on what is exported by Protolude check:
|
||||
https://github.com/sdiehl/protolude/blob/master/Symbols.md
|
||||
-}
|
||||
module Lib.Prelude
|
||||
( module Exports
|
||||
, both
|
||||
|
||||
, format
|
||||
, formatBS
|
||||
) where
|
||||
|
||||
import Protolude as Exports
|
||||
@ -37,10 +32,12 @@ import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)
|
||||
import Data.Text.Format as Exports (Shown(..))
|
||||
import qualified Data.Text.Format as TF
|
||||
import Data.Text.Format.Params (Params)
|
||||
import qualified Data.Text.Lazy as LT
|
||||
|
||||
format :: Params ps => TF.Format -> ps -> Text
|
||||
format f args = LT.toStrict $ TF.format f args
|
||||
format f args = toS $ TF.format f args
|
||||
|
||||
formatBS :: Params ps => TF.Format -> ps -> ByteString
|
||||
formatBS f args = toS $ TF.format f args
|
||||
|
||||
-- import Data.Tuple as Exports (uncurry)
|
||||
|
||||
|
||||
@ -75,6 +75,12 @@ module Network.Minio
|
||||
, statObject
|
||||
, removeIncompleteUpload
|
||||
|
||||
-- * Presigned Operations
|
||||
-------------------------
|
||||
, UrlExpiry
|
||||
, presignedPutObjectURL
|
||||
, presignedGetObjectURL
|
||||
, presignedHeadObjectURL
|
||||
) where
|
||||
|
||||
{-
|
||||
@ -145,7 +151,7 @@ statObject = headObject
|
||||
-- configured in ConnectInfo, which is by default, the US Standard
|
||||
-- Region.
|
||||
makeBucket :: Bucket -> Maybe Region -> Minio ()
|
||||
makeBucket bucket regionMay= do
|
||||
makeBucket bucket regionMay = do
|
||||
region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay
|
||||
putBucket bucket region
|
||||
modify (Map.insert bucket region)
|
||||
|
||||
@ -39,6 +39,7 @@ import qualified Data.ByteString as B
|
||||
import Network.HTTP.Conduit (Response)
|
||||
import qualified Network.HTTP.Conduit as NC
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import Network.HTTP.Types.Header (hHost)
|
||||
|
||||
import Lib.Prelude
|
||||
|
||||
@ -122,13 +123,18 @@ buildRequest ri = do
|
||||
|
||||
|
||||
sha256Hash <- getPayloadSHA256Hash (riPayload ri)
|
||||
let newRi = ri { riPayloadHash = sha256Hash
|
||||
, riHeaders = sha256Header sha256Hash : riHeaders ri
|
||||
let hostHeader = (hHost, formatBS "{}:{}" [connectHost ci,
|
||||
show $ connectPort ci])
|
||||
|
||||
newRi = ri { riPayloadHash = Just sha256Hash
|
||||
, riHeaders = hostHeader
|
||||
: sha256Header sha256Hash
|
||||
: riHeaders ri
|
||||
, riRegion = region
|
||||
}
|
||||
newCi = ci { connectHost = regionHost }
|
||||
|
||||
reqHeaders <- liftIO $ signV4 newCi newRi
|
||||
signHeaders <- liftIO $ signV4 newCi newRi Nothing
|
||||
|
||||
return NC.defaultRequest {
|
||||
NC.method = riMethod newRi
|
||||
@ -137,7 +143,7 @@ buildRequest ri = do
|
||||
, NC.port = connectPort newCi
|
||||
, NC.path = getPathFromRI newRi
|
||||
, NC.queryString = HT.renderQuery False $ riQueryParams newRi
|
||||
, NC.requestHeaders = reqHeaders
|
||||
, NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders
|
||||
, NC.requestBody = getRequestBody (riPayload newRi)
|
||||
}
|
||||
|
||||
|
||||
@ -233,10 +233,10 @@ data ObjectInfo = ObjectInfo {
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data CopyPartSource = CopyPartSource {
|
||||
cpSource :: Text -- | formatted like "\/sourceBucket\/sourceObject"
|
||||
, cpSourceRange :: Maybe (Int64, Int64) -- | (0, 9) means first ten
|
||||
-- bytes of the source
|
||||
-- object
|
||||
-- | formatted like "\/sourceBucket\/sourceObject"
|
||||
cpSource :: Text
|
||||
-- | (0, 9) means first ten bytes of the source object
|
||||
, cpSourceRange :: Maybe (Int64, Int64)
|
||||
, cpSourceIfMatch :: Maybe Text
|
||||
, cpSourceIfNoneMatch :: Maybe Text
|
||||
, cpSourceIfUnmodifiedSince :: Maybe UTCTime
|
||||
@ -289,19 +289,26 @@ data RequestInfo = RequestInfo {
|
||||
, riQueryParams :: Query
|
||||
, riHeaders :: [Header]
|
||||
, riPayload :: Payload
|
||||
, riPayloadHash :: ByteString
|
||||
, riPayloadHash :: Maybe ByteString
|
||||
, riRegion :: Maybe Region
|
||||
, riNeedsLocation :: Bool
|
||||
}
|
||||
|
||||
instance Default RequestInfo where
|
||||
def = RequestInfo HT.methodGet def def def def def "" def True
|
||||
def = RequestInfo HT.methodGet def def def def def Nothing def True
|
||||
|
||||
getPathFromRI :: RequestInfo -> ByteString
|
||||
getPathFromRI ri = B.concat parts
|
||||
where
|
||||
objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri
|
||||
parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ riBucket ri
|
||||
getPathFromRI ri =
|
||||
let
|
||||
b = riBucket ri
|
||||
o = riObject ri
|
||||
segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)
|
||||
in
|
||||
B.concat ["/", B.intercalate "/" segments]
|
||||
|
||||
-- | Time to expire for a presigned URL. It interpreted as a number of
|
||||
-- seconds. The maximum duration that can be specified is 7 days.
|
||||
type UrlExpiry = Int
|
||||
|
||||
type RegionMap = Map.Map Bucket Region
|
||||
|
||||
|
||||
@ -37,6 +37,7 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
|
||||
| MErrVXmlParse Text
|
||||
| MErrVInvalidBucketName Text
|
||||
| MErrVInvalidObjectName Text
|
||||
| MErrVInvalidUrlExpiry Int
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Exception MErrV
|
||||
|
||||
@ -64,19 +64,29 @@ module Network.Minio.S3API
|
||||
, deleteBucket
|
||||
, deleteObject
|
||||
|
||||
-- * Presigned URL Operations
|
||||
-----------------------------
|
||||
, UrlExpiry
|
||||
, makePresignedURL
|
||||
, presignedPutObjectURL
|
||||
, presignedGetObjectURL
|
||||
, presignedHeadObjectURL
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (catches, Handler(..))
|
||||
import qualified Data.Conduit as C
|
||||
import Data.Default (def)
|
||||
import Data.ByteString.Builder (toLazyByteString, byteString)
|
||||
import qualified Network.HTTP.Conduit as NC
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import Network.HTTP.Types.Status (status404)
|
||||
import Network.HTTP.Types.Header (hHost)
|
||||
|
||||
import Lib.Prelude hiding (catches)
|
||||
|
||||
import Network.Minio.API
|
||||
import Network.Minio.Data
|
||||
import Network.Minio.Sign.V4
|
||||
import Network.Minio.Errors
|
||||
import Network.Minio.Utils
|
||||
import Network.Minio.XmlGenerator
|
||||
@ -358,3 +368,83 @@ headBucket bucket = headBucketEx `catches`
|
||||
, riBucket = Just bucket
|
||||
}
|
||||
return $ NC.responseStatus resp == HT.ok200
|
||||
|
||||
-- | Generate a presigned URL. This function allows for advanced usage
|
||||
-- - for simple cases prefer the `presigned*URL` functions.
|
||||
--
|
||||
-- If region is Nothing, it is picked up from the connection
|
||||
-- information (no check of bucket existence is performed).
|
||||
--
|
||||
-- All extra query parameters or headers are signed, and therefore are
|
||||
-- required to be sent when the generated URL is actually used.
|
||||
makePresignedURL :: UrlExpiry -> HT.Method -> Maybe Bucket -> Maybe Object
|
||||
-> Maybe Region -> HT.Query -> HT.RequestHeaders
|
||||
-> Minio ByteString
|
||||
makePresignedURL expiry method bucket object region extraQuery extraHeaders = do
|
||||
when (expiry > 7*24*3600 || expiry < 0) $
|
||||
throwM $ MErrVInvalidUrlExpiry expiry
|
||||
|
||||
|
||||
ci <- asks mcConnInfo
|
||||
|
||||
let
|
||||
host = formatBS "{}:{}" (connectHost ci, connectPort ci)
|
||||
hostHeader = (hHost, host)
|
||||
ri = def { riMethod = method
|
||||
, riBucket = bucket
|
||||
, riObject = object
|
||||
, riQueryParams = extraQuery
|
||||
, riHeaders = hostHeader : extraHeaders
|
||||
, riRegion = Just $ maybe (connectRegion ci) identity region
|
||||
}
|
||||
|
||||
signPairs <- liftIO $ signV4 ci ri (Just expiry)
|
||||
|
||||
let
|
||||
qpToAdd = (fmap . fmap) Just signPairs
|
||||
queryStr = HT.renderQueryBuilder True (riQueryParams ri ++ qpToAdd)
|
||||
scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
|
||||
|
||||
return $ toS $ toLazyByteString $
|
||||
scheme <> byteString host <> byteString (getPathFromRI ri) <> queryStr
|
||||
|
||||
-- | Generate a URL with authentication signature to PUT (upload) an
|
||||
-- object. Any extra headers if passed, are signed, and so they are
|
||||
-- required when the URL is used to upload data. This could be used,
|
||||
-- for example, to set user-metadata on the object.
|
||||
--
|
||||
-- For a list of possible headers to pass, please refer to the PUT
|
||||
-- object REST API AWS S3 documentation.
|
||||
presignedPutObjectURL :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders
|
||||
-> Minio ByteString
|
||||
presignedPutObjectURL bucket object expirySeconds extraHeaders =
|
||||
makePresignedURL expirySeconds HT.methodPut
|
||||
(Just bucket) (Just object) Nothing [] extraHeaders
|
||||
|
||||
-- | Generate a URL with authentication signature to GET (download) an
|
||||
-- object. All extra query parameters and headers passed here will be
|
||||
-- signed and are required when the generated URL is used. Query
|
||||
-- parameters could be used to change the response headers sent by the
|
||||
-- server. Headers can be used to set Etag match conditions among
|
||||
-- others.
|
||||
--
|
||||
-- For a list of possible request parameters and headers, please refer
|
||||
-- to the GET object REST API AWS S3 documentation.
|
||||
presignedGetObjectURL :: Bucket -> Object -> UrlExpiry -> HT.Query
|
||||
-> HT.RequestHeaders -> Minio ByteString
|
||||
presignedGetObjectURL bucket object expirySeconds extraQuery extraHeaders =
|
||||
makePresignedURL expirySeconds HT.methodGet
|
||||
(Just bucket) (Just object) Nothing extraQuery extraHeaders
|
||||
|
||||
-- | Generate a URL with authentication signature to make a HEAD
|
||||
-- request on an object. This is used to fetch metadata about an
|
||||
-- object. All extra headers passed here will be signed and are
|
||||
-- required when the generated URL is used.
|
||||
--
|
||||
-- For a list of possible headers to pass, please refer to the HEAD
|
||||
-- object REST API AWS S3 documentation.
|
||||
presignedHeadObjectURL :: Bucket -> Object -> UrlExpiry
|
||||
-> HT.RequestHeaders -> Minio ByteString
|
||||
presignedHeadObjectURL bucket object expirySeconds extraHeaders =
|
||||
makePresignedURL expirySeconds HT.methodHead
|
||||
(Just bucket) (Just object) Nothing [] extraHeaders
|
||||
|
||||
@ -18,21 +18,24 @@ module Network.Minio.Sign.V4
|
||||
(
|
||||
signV4
|
||||
, signV4AtTime
|
||||
, getScope
|
||||
, mkScope
|
||||
, getHeadersToSign
|
||||
, getCanonicalRequest
|
||||
, mkCanonicalRequest
|
||||
, mkStringToSign
|
||||
, mkSigningKey
|
||||
, computeSignature
|
||||
, SignV4Data(..)
|
||||
, debugPrintSignV4Data
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import Data.ByteString.Char8 (pack)
|
||||
import Data.CaseInsensitive (mk)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Time as Time
|
||||
import Network.HTTP.Types (Header)
|
||||
import qualified Network.HTTP.Types.Header as H
|
||||
|
||||
import Lib.Prelude
|
||||
import Network.Minio.Data
|
||||
@ -40,35 +43,35 @@ import Network.Minio.Data.ByteString
|
||||
import Network.Minio.Data.Crypto
|
||||
import Network.Minio.Data.Time
|
||||
|
||||
-- these headers are not included in the string to sign when signing a
|
||||
-- request
|
||||
ignoredHeaders :: Set ByteString
|
||||
ignoredHeaders = Set.fromList $ map CI.foldedCase [
|
||||
mk "Authorization",
|
||||
mk "Content-Type",
|
||||
mk "Content-Length",
|
||||
mk "User-Agent"
|
||||
]
|
||||
ignoredHeaders = Set.fromList $ map CI.foldedCase
|
||||
[ H.hAuthorization
|
||||
, H.hContentType
|
||||
, H.hContentLength
|
||||
, H.hUserAgent
|
||||
]
|
||||
|
||||
data SignV4Data = SignV4Data {
|
||||
sv4SignTime :: UTCTime
|
||||
, sv4Scope :: ByteString
|
||||
, sv4CanonicalRequest :: ByteString
|
||||
, sv4HeadersToSign :: [(ByteString, ByteString)]
|
||||
, sv4InputHeaders :: [Header]
|
||||
, sv4OutputHeaders :: [Header]
|
||||
, sv4Output :: [(ByteString, ByteString)]
|
||||
, sv4StringToSign :: ByteString
|
||||
, sv4SigningKey :: ByteString
|
||||
} deriving (Show)
|
||||
|
||||
debugPrintSignV4Data :: SignV4Data -> IO ()
|
||||
debugPrintSignV4Data (SignV4Data t s cr h2s ih oh sts sk) = do
|
||||
debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
|
||||
B8.putStrLn "SignV4Data:"
|
||||
B8.putStr "Timestamp: " >> print t
|
||||
B8.putStr "Scope: " >> B8.putStrLn s
|
||||
B8.putStrLn "Canonical Request:"
|
||||
B8.putStrLn cr
|
||||
B8.putStr "Headers to Sign: " >> print h2s
|
||||
B8.putStr "Input headers: " >> print ih
|
||||
B8.putStr "Output headers: " >> print oh
|
||||
B8.putStr "Output: " >> print o
|
||||
B8.putStr "StringToSign: " >> B8.putStrLn sts
|
||||
B8.putStr "SigningKey: " >> printBytes sk
|
||||
B8.putStrLn "END of SignV4Data ========="
|
||||
@ -81,94 +84,145 @@ debugPrintSignV4Data (SignV4Data t s cr h2s ih oh sts sk) = do
|
||||
-- request path, headers, query params and payload hash, generates an
|
||||
-- updated set of headers, including the x-amz-date header and the
|
||||
-- Authorization header, which includes the signature.
|
||||
signV4 :: ConnectInfo -> RequestInfo
|
||||
-> IO [Header]
|
||||
signV4 ci ri = do
|
||||
signV4 :: ConnectInfo -> RequestInfo -> Maybe Int
|
||||
-> IO [(ByteString, ByteString)]
|
||||
signV4 !ci !ri !expiry = do
|
||||
timestamp <- Time.getCurrentTime
|
||||
let signData = signV4AtTime timestamp ci ri
|
||||
let signData = signV4AtTime timestamp ci ri expiry
|
||||
-- debugPrintSignV4Data signData
|
||||
return $ sv4OutputHeaders signData
|
||||
return $ sv4Output signData
|
||||
|
||||
-- | Takes a timestamp, server params and request params and generates
|
||||
-- an updated list of headers.
|
||||
signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> SignV4Data
|
||||
signV4AtTime ts ci ri =
|
||||
SignV4Data ts scope canonicalRequest headersToSign (riHeaders ri) outHeaders stringToSign signingKey
|
||||
where
|
||||
outHeaders = authHeader : headersWithDate
|
||||
timeBS = awsTimeFormatBS ts
|
||||
dateHeader = (mk "X-Amz-Date", timeBS)
|
||||
hostHeader = (mk "host", encodeUtf8 $ format "{}:{}"
|
||||
[connectHost ci, show $ connectPort ci])
|
||||
|
||||
headersWithDate = dateHeader : hostHeader : riHeaders ri
|
||||
|
||||
authHeader = (mk "Authorization", authHeaderValue)
|
||||
|
||||
-- AWS Sign V4 data. For normal requests (i.e. without an expiry
|
||||
-- time), the output is the list of headers to add to authenticate the
|
||||
-- request.
|
||||
--
|
||||
-- If `expiry` is not Nothing, it is assumed that a presigned request
|
||||
-- is being created. The expiry is interpreted as an integer number of
|
||||
-- seconds. The output will be the list of query-parameters to add to
|
||||
-- the request.
|
||||
signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> Maybe Int
|
||||
-> SignV4Data
|
||||
signV4AtTime ts ci ri expiry =
|
||||
let
|
||||
region = maybe (connectRegion ci) identity $ riRegion ri
|
||||
scope = mkScope ts region
|
||||
accessKey = toS $ connectAccessKey ci
|
||||
secretKey = toS $ connectSecretKey ci
|
||||
|
||||
scope = getScope ts region
|
||||
-- headers to be added to the request
|
||||
datePair = ("X-Amz-Date", awsTimeFormatBS ts)
|
||||
computedHeaders = riHeaders ri ++
|
||||
if isJust expiry
|
||||
then []
|
||||
else [(\(x, y) -> (mk x, y)) datePair]
|
||||
headersToSign = getHeadersToSign computedHeaders
|
||||
signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
|
||||
|
||||
authHeaderValue = B.concat [
|
||||
"AWS4-HMAC-SHA256 Credential=",
|
||||
encodeUtf8 (connectAccessKey ci), "/", scope,
|
||||
", SignedHeaders=", signedHeaders,
|
||||
", Signature=", signature
|
||||
]
|
||||
-- query-parameters to be added before signing for presigned URLs
|
||||
-- (i.e. when `isJust expiry`)
|
||||
authQP = [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256")
|
||||
, ("X-Amz-Credential", B.concat [accessKey, "/", scope])
|
||||
, datePair
|
||||
, ("X-Amz-Expires", maybe "" show expiry)
|
||||
, ("X-Amz-SignedHeaders", signedHeaderKeys)
|
||||
]
|
||||
finalQP = riQueryParams ri ++
|
||||
if isJust expiry
|
||||
then (fmap . fmap) Just authQP
|
||||
else []
|
||||
|
||||
headersToSign = getHeadersToSign headersWithDate
|
||||
-- 1. compute canonical request
|
||||
canonicalRequest = mkCanonicalRequest (ri {riQueryParams = finalQP})
|
||||
headersToSign
|
||||
|
||||
signedHeaders = B.intercalate ";" $ map fst headersToSign
|
||||
-- 2. compute string to sign
|
||||
stringToSign = mkStringToSign ts scope canonicalRequest
|
||||
|
||||
signature = digestToBase16 $ hmacSHA256 stringToSign signingKey
|
||||
-- 3.1 compute signing key
|
||||
signingKey = mkSigningKey ts region secretKey
|
||||
|
||||
signingKey = hmacSHA256RawBS "aws4_request"
|
||||
. hmacSHA256RawBS "s3"
|
||||
. hmacSHA256RawBS (encodeUtf8 region)
|
||||
. hmacSHA256RawBS (awsDateFormatBS ts)
|
||||
$ B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci]
|
||||
-- 3.2 compute signature
|
||||
signature = computeSignature stringToSign signingKey
|
||||
|
||||
stringToSign = B.intercalate "\n"
|
||||
[ "AWS4-HMAC-SHA256"
|
||||
, timeBS
|
||||
-- 4. compute auth header
|
||||
authValue = B.concat
|
||||
[ "AWS4-HMAC-SHA256 Credential="
|
||||
, accessKey
|
||||
, "/"
|
||||
, scope
|
||||
, hashSHA256 canonicalRequest
|
||||
, ", SignedHeaders="
|
||||
, signedHeaderKeys
|
||||
, ", Signature="
|
||||
, signature
|
||||
]
|
||||
authHeader = (H.hAuthorization, authValue)
|
||||
|
||||
canonicalRequest = getCanonicalRequest ri headersToSign
|
||||
-- finally compute output pairs
|
||||
output = if isJust expiry
|
||||
then ("X-Amz-Signature", signature) : authQP
|
||||
else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,
|
||||
datePair]
|
||||
|
||||
in
|
||||
SignV4Data ts scope canonicalRequest headersToSign output
|
||||
stringToSign signingKey
|
||||
|
||||
|
||||
getScope :: UTCTime -> Region -> ByteString
|
||||
getScope ts region = B.intercalate "/" [
|
||||
pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,
|
||||
encodeUtf8 region, "s3", "aws4_request"
|
||||
mkScope :: UTCTime -> Region -> ByteString
|
||||
mkScope ts region = B.intercalate "/"
|
||||
[ toS $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts
|
||||
, toS region
|
||||
, "s3"
|
||||
, "aws4_request"
|
||||
]
|
||||
|
||||
getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
|
||||
getHeadersToSign h =
|
||||
sort $
|
||||
getHeadersToSign !h =
|
||||
filter (flip Set.notMember ignoredHeaders . fst) $
|
||||
map (\(x, y) -> (CI.foldedCase x, stripBS y)) h
|
||||
|
||||
getCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)] -> ByteString
|
||||
getCanonicalRequest ri headersForSign = B.intercalate "\n" [
|
||||
riMethod ri,
|
||||
uriEncode False path,
|
||||
canonicalQueryString,
|
||||
canonicalHeaders,
|
||||
signedHeaders,
|
||||
riPayloadHash ri
|
||||
]
|
||||
where
|
||||
path = getPathFromRI ri
|
||||
|
||||
mkCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)]
|
||||
-> ByteString
|
||||
mkCanonicalRequest !ri !headersForSign =
|
||||
let
|
||||
canonicalQueryString = B.intercalate "&" $
|
||||
map (\(x, y) -> B.concat [x, "=", y]) $
|
||||
sort $ map (\(x, y) ->
|
||||
(uriEncode True x, maybe "" (uriEncode True) y)) $
|
||||
riQueryParams ri
|
||||
|
||||
canonicalHeaders = B.concat $
|
||||
map (\(x, y) -> B.concat [x, ":", y, "\n"]) headersForSign
|
||||
sortedHeaders = sort headersForSign
|
||||
|
||||
signedHeaders = B.intercalate ";" $ map fst headersForSign
|
||||
canonicalHeaders = B.concat $
|
||||
map (\(x, y) -> B.concat [x, ":", y, "\n"]) sortedHeaders
|
||||
|
||||
signedHeaders = B.intercalate ";" $ map fst sortedHeaders
|
||||
|
||||
in
|
||||
B.intercalate "\n"
|
||||
[ riMethod ri
|
||||
, uriEncode False $ getPathFromRI ri
|
||||
, canonicalQueryString
|
||||
, canonicalHeaders
|
||||
, signedHeaders
|
||||
, maybe "UNSIGNED-PAYLOAD" identity $ riPayloadHash ri
|
||||
]
|
||||
|
||||
mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
|
||||
mkStringToSign ts !scope !canonicalRequest = B.intercalate "\n"
|
||||
[ "AWS4-HMAC-SHA256"
|
||||
, awsTimeFormatBS ts
|
||||
, scope
|
||||
, hashSHA256 canonicalRequest
|
||||
]
|
||||
|
||||
mkSigningKey :: UTCTime -> Region -> ByteString -> ByteString
|
||||
mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request"
|
||||
. hmacSHA256RawBS "s3"
|
||||
. hmacSHA256RawBS (toS region)
|
||||
. hmacSHA256RawBS (awsDateFormatBS ts)
|
||||
$ B.concat ["AWS4", secretKey]
|
||||
|
||||
computeSignature :: ByteString -> ByteString -> ByteString
|
||||
computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key
|
||||
|
||||
@ -35,6 +35,8 @@ import qualified Network.HTTP.Conduit as NC
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import qualified Network.HTTP.Types.Header as Hdr
|
||||
import qualified System.IO as IO
|
||||
import Data.CaseInsensitive (mk)
|
||||
|
||||
|
||||
import Lib.Prelude
|
||||
|
||||
@ -87,6 +89,8 @@ withNewHandle fp fileAction = do
|
||||
R.release rkey
|
||||
return resE
|
||||
|
||||
mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header]
|
||||
mkHeaderFromPairs = map ((\(x, y) -> (mk x, y)))
|
||||
|
||||
lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString
|
||||
lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr)
|
||||
|
||||
@ -27,13 +27,17 @@ import qualified System.IO as SIO
|
||||
import qualified Control.Monad.Catch as MC
|
||||
import qualified Control.Monad.Trans.Resource as R
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Conduit (($$), yield)
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
import Data.Conduit.Combinators (sinkList)
|
||||
import Data.Default (Default(..))
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import System.Environment (lookupEnv)
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import qualified Network.HTTP.Conduit as NC
|
||||
|
||||
import Network.Minio
|
||||
import Network.Minio.Data
|
||||
@ -476,4 +480,89 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
|
||||
liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"
|
||||
|
||||
forM_ [src, copyObj] (removeObject bucket)
|
||||
|
||||
, presignedFunTest
|
||||
]
|
||||
|
||||
presignedFunTest :: TestTree
|
||||
presignedFunTest = funTestWithBucket "presigned URL tests" $
|
||||
\step bucket -> do
|
||||
let obj = "mydir/myput"
|
||||
obj2 = "mydir1/myfile1"
|
||||
|
||||
-- manager for http requests
|
||||
mgr <- liftIO $ NC.newManager NC.tlsManagerSettings
|
||||
|
||||
step "PUT object presigned URL - makePresignedURL"
|
||||
putUrl <- makePresignedURL 3600 HT.methodPut (Just bucket)
|
||||
(Just obj) (Just "us-east-1") [] []
|
||||
|
||||
let size1 = 1000 :: Int64
|
||||
inputFile <- mkRandFile size1
|
||||
|
||||
-- attempt to upload using the presigned URL
|
||||
putResp <- putR size1 inputFile mgr putUrl
|
||||
liftIO $ (NC.responseStatus putResp == HT.status200) @?
|
||||
"presigned PUT failed"
|
||||
|
||||
step "GET object presigned URL - makePresignedURL"
|
||||
getUrl <- makePresignedURL 3600 HT.methodGet (Just bucket)
|
||||
(Just obj) (Just "us-east-1") [] []
|
||||
|
||||
getResp <- getR mgr getUrl
|
||||
liftIO $ (NC.responseStatus getResp == HT.status200) @?
|
||||
"presigned GET failed"
|
||||
|
||||
-- read content from file to compare with response above
|
||||
bs <- CB.sourceFile inputFile $$ CB.sinkLbs
|
||||
liftIO $ (bs == NC.responseBody getResp) @?
|
||||
"presigned put and get got mismatched data"
|
||||
|
||||
step "PUT object presigned - presignedPutObjectURL"
|
||||
putUrl2 <- presignedPutObjectURL bucket obj2 3600 []
|
||||
|
||||
let size2 = 1200
|
||||
testFile <- mkRandFile size2
|
||||
|
||||
putResp2 <- putR size2 testFile mgr putUrl2
|
||||
liftIO $ (NC.responseStatus putResp2 == HT.status200) @?
|
||||
"presigned PUT failed (presignedPutObjectURL)"
|
||||
|
||||
step "HEAD object presigned URL - presignedHeadObjectURL"
|
||||
headUrl <- presignedHeadObjectURL bucket obj2 3600 []
|
||||
|
||||
headResp <- do req <- NC.parseRequest $ toS headUrl
|
||||
NC.httpLbs (req {NC.method = HT.methodHead}) mgr
|
||||
liftIO $ (NC.responseStatus headResp == HT.status200) @?
|
||||
"presigned HEAD failed (presignedHeadObjectURL)"
|
||||
|
||||
-- check that header info is accurate
|
||||
let h = Map.fromList $ NC.responseHeaders headResp
|
||||
cLen = Map.findWithDefault "0" HT.hContentLength h
|
||||
liftIO $ (cLen == show size2) @? "Head req returned bad content length"
|
||||
|
||||
step "GET object presigned URL - presignedGetObjectURL"
|
||||
getUrl2 <- presignedGetObjectURL bucket obj2 3600 [] []
|
||||
|
||||
getResp2 <- getR mgr getUrl2
|
||||
liftIO $ (NC.responseStatus getResp2 == HT.status200) @?
|
||||
"presigned GET failed (presignedGetObjectURL)"
|
||||
|
||||
-- read content from file to compare with response above
|
||||
bs2 <- CB.sourceFile testFile $$ CB.sinkLbs
|
||||
liftIO $ (bs2 == NC.responseBody getResp2) @?
|
||||
"presigned put and get got mismatched data (presigned*URL)"
|
||||
|
||||
|
||||
mapM_ (removeObject bucket) [obj, obj2]
|
||||
where
|
||||
putR size filePath mgr url = do
|
||||
req <- NC.parseRequest $ toS url
|
||||
let req' = req { NC.method = HT.methodPut
|
||||
, NC.requestBody = NC.requestBodySource size $
|
||||
CB.sourceFile filePath}
|
||||
NC.httpLbs req' mgr
|
||||
|
||||
getR mgr url = do
|
||||
req <- NC.parseRequest $ toS url
|
||||
NC.httpLbs req mgr
|
||||
|
||||
Loading…
Reference in New Issue
Block a user