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.

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

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)
 

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)

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
+  let hostHeader = (hHost, formatBS "{}:{}" [connectHost ci,
-                 , riHeaders = sha256Header sha256Hash : riHeaders ri
+                                             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)
     }
 

src/Network/Minio/Data.hs

@@ -233,10 +233,10 @@ data ObjectInfo = ObjectInfo {
   } deriving (Show, Eq)
 
 data CopyPartSource = CopyPartSource {
-    cpSource :: Text -- | formatted like "\/sourceBucket\/sourceObject"
+    -- | formatted like "\/sourceBucket\/sourceObject"
-  , cpSourceRange :: Maybe (Int64, Int64) -- | (0, 9) means first ten
+    cpSource :: Text
-                                          -- bytes of the source
+    -- | (0, 9) means first ten bytes of the source object
-                                          -- 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
+getPathFromRI ri =
-  where
+  let
-    objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri
+    b = riBucket ri
-    parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ 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
 

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

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

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 [
+ignoredHeaders = Set.fromList $ map CI.foldedCase
-  mk "Authorization",
+                 [ H.hAuthorization
-  mk "Content-Type",
+                 , H.hContentType
-  mk "Content-Length",
+                 , H.hContentLength
-  mk "User-Agent"
+                 , H.hUserAgent
-  ]
+                 ]
 
 data SignV4Data = SignV4Data {
     sv4SignTime :: UTCTime
   , sv4Scope :: ByteString
   , sv4CanonicalRequest :: ByteString
   , sv4HeadersToSign :: [(ByteString, ByteString)]
-  , sv4InputHeaders :: [Header]
+  , sv4Output :: [(ByteString, ByteString)]
-  , sv4OutputHeaders :: [Header]
   , 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: " >> print o
-  B8.putStr "Output headers: " >> print oh
   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
+signV4 :: ConnectInfo -> RequestInfo -> Maybe Int
-       -> IO [Header]
+       -> IO [(ByteString, ByteString)]
-signV4 ci ri = do
+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.
+-- AWS Sign V4 data. For normal requests (i.e. without an expiry
-signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> SignV4Data
+-- time), the output is the list of headers to add to authenticate the
-signV4AtTime ts ci ri =
+-- request.
-  SignV4Data ts scope canonicalRequest headersToSign (riHeaders ri) outHeaders stringToSign signingKey
+--
-  where
+-- If `expiry` is not Nothing, it is assumed that a presigned request
-    outHeaders = authHeader : headersWithDate
+-- is being created. The expiry is interpreted as an integer number of
-    timeBS = awsTimeFormatBS ts
+-- seconds. The output will be the list of query-parameters to add to
-    dateHeader = (mk "X-Amz-Date", timeBS)
+-- the request.
-    hostHeader = (mk "host", encodeUtf8 $ format "{}:{}"
+signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> Maybe Int
-                   [connectHost ci, show $ connectPort ci])
+             -> SignV4Data
-
+signV4AtTime ts ci ri expiry =
-    headersWithDate = dateHeader : hostHeader : riHeaders ri
+  let
-
-    authHeader = (mk "Authorization", authHeaderValue)
-
     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 [
+    -- query-parameters to be added before signing for presigned URLs
-      "AWS4-HMAC-SHA256 Credential=",
+    -- (i.e. when `isJust expiry`)
-      encodeUtf8 (connectAccessKey ci), "/", scope,
+    authQP = [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256")
-      ", SignedHeaders=", signedHeaders,
+             , ("X-Amz-Credential", B.concat [accessKey, "/", scope])
-      ", Signature=", signature
+             , 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"
+    -- 3.2 compute signature
-               . hmacSHA256RawBS "s3"
+    signature = computeSignature stringToSign signingKey
-               . hmacSHA256RawBS (encodeUtf8 region)
-               . hmacSHA256RawBS (awsDateFormatBS ts)
-               $ B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci]
 
-    stringToSign  = B.intercalate "\n"
+    -- 4. compute auth header
-      [ "AWS4-HMAC-SHA256"
+    authValue = B.concat
-      , timeBS
+      [ "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
+mkScope :: UTCTime -> Region -> ByteString
-getScope ts region = B.intercalate "/" [
+mkScope ts region = B.intercalate "/"
-  pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,
+  [ toS $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts
-  encodeUtf8 region, "s3", "aws4_request"
+  , toS region
+  , "s3"
+  , "aws4_request"
   ]
 
 getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
-getHeadersToSign h =
+getHeadersToSign !h =
-  sort $
   filter (flip Set.notMember ignoredHeaders . fst) $
   map (\(x, y) -> (CI.foldedCase x, stripBS y)) h
 
-getCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)] -> ByteString
+mkCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)]
-getCanonicalRequest ri headersForSign = B.intercalate "\n" [
+                    -> ByteString
-  riMethod ri,
+mkCanonicalRequest !ri !headersForSign =
-  uriEncode False path,
+  let
-  canonicalQueryString,
-  canonicalHeaders,
-  signedHeaders,
-  riPayloadHash ri
-  ]
-  where
-    path = getPathFromRI ri
-
     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 $
+    sortedHeaders = sort headersForSign
-      map (\(x, y) -> B.concat [x, ":", y, "\n"]) 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

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)

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