diff --git a/minio-hs.cabal b/minio-hs.cabal index 48569ba..a7efa05 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -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 diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs index 180e83d..c7ebbae 100644 --- a/src/Lib/Prelude.hs +++ b/src/Lib/Prelude.hs @@ -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) diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 702fd53..46834f4 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -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) diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 5a6ad26..64723e7 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -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) } diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 17924b4..5181b15 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -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 diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs index e47b3ff..afec3fa 100644 --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -37,6 +37,7 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64 | MErrVXmlParse Text | MErrVInvalidBucketName Text | MErrVInvalidObjectName Text + | MErrVInvalidUrlExpiry Int deriving (Show, Eq) instance Exception MErrV diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 48faaf3..542dcb1 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -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 diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 792ed20..fdfcea8 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -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 diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 2e6700e..a8e9673 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -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) diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 543113e..7c8ebad 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -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