Use region specific endpoints for AWS S3 in presigned Urls (#164)

- Also update standard S3 endpoints - Unify code that determines if path style or virtual style must be used for regular and presigned requests Fixes #160
2021-03-08 16:35:52 -08:00 · 2021-03-08 16:35:52 -08:00 · aa2382b2e9
commit aa2382b2e9
parent b8cc1e57ee
8 changed files with 132 additions and 91 deletions
--- a/minio-hs.cabal
+++ b/minio-hs.cabal
@ -77,6 +77,7 @@ common base-settings
                     , http-types >= 0.12
                     , ini
                     , memory >= 0.14
+                     , network-uri
                     , raw-strings-qq >= 1
                     , resourcet >= 1.2
                     , retry
--- a/src/Network/Minio/API.hs
+++ b/src/Network/Minio/API.hs
@ -19,6 +19,7 @@ module Network.Minio.API
    S3ReqInfo (..),
    runMinio,
    executeRequest,
+    buildRequest,
    mkStreamRequest,
    getLocation,
    isValidBucketName,
@ -40,6 +41,7 @@ import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import qualified Data.Time.Clock as Time
 import Lib.Prelude
+import qualified Network.HTTP.Client as NClient
 import Network.HTTP.Conduit (Response)
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
@ -78,6 +80,7 @@ discoverRegion ri = runMaybeT $ do
    return
    regionMay

+-- | Returns the region to be used for the request.
 getRegion :: S3ReqInfo -> Minio (Maybe Region)
 getRegion ri = do
  ci <- asks mcConnInfo
@ -104,6 +107,42 @@ getRegionHost r = do
        (H.lookup r awsRegionMap)
    else return $ connectHost ci

+-- | Computes the appropriate host, path and region for the request.
+--
+-- For AWS, always use virtual bucket style, unless bucket has periods. For
+-- MinIO and other non-AWS, default to path style.
+getHostPathRegion :: S3ReqInfo -> Minio (Text, ByteString, Maybe Region)
+getHostPathRegion ri = do
+  ci <- asks mcConnInfo
+  regionMay <- getRegion ri
+  case riBucket ri of
+    Nothing ->
+      -- Implies a ListBuckets request.
+      return (connectHost ci, "/", regionMay)
+    Just bucket -> do
+      regionHost <- case regionMay of
+        Nothing -> return $ connectHost ci
+        Just "" -> return $ connectHost ci
+        Just r -> getRegionHost r
+      let pathStyle =
+            ( regionHost,
+              getS3Path (riBucket ri) (riObject ri),
+              regionMay
+            )
+          virtualStyle =
+            ( ( bucket <> "." <> regionHost,
+                encodeUtf8 $ "/" <> fromMaybe "" (riObject ri),
+                regionMay
+              )
+            )
+      if
+          | isAWSConnectInfo ci ->
+            return $
+              if bucketHasPeriods bucket
+                then pathStyle
+                else virtualStyle
+          | otherwise -> return pathStyle
+
 buildRequest :: S3ReqInfo -> Minio NC.Request
 buildRequest ri = do
  maybe (return ()) checkBucketNameValidity $ riBucket ri
@ -111,17 +150,15 @@ buildRequest ri = do

  ci <- asks mcConnInfo

-  regionMay <- getRegion ri
+  (host, path, regionMay) <- getHostPathRegion ri

-  regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay
-
-  let ri' =
+  let ci' = ci {connectHost = host}
+      hostHeader = (hHost, getHostAddr ci')
+      ri' =
        ri
          { riHeaders = hostHeader : riHeaders ri,
            riRegion = regionMay
          }
-      ci' = ci {connectHost = regionHost}
-      hostHeader = (hHost, getHostAddr ci')
      -- Does not contain body and auth info.
      baseRequest =
        NC.defaultRequest
@ -129,7 +166,7 @@ buildRequest ri = do
            NC.secure = connectIsSecure ci',
            NC.host = encodeUtf8 $ connectHost ci',
            NC.port = connectPort ci',
-            NC.path = getS3Path (riBucket ri') (riObject ri'),
+            NC.path = path,
            NC.requestHeaders = riHeaders ri',
            NC.queryString = HT.renderQuery False $ riQueryParams ri'
          }
@ -142,11 +179,13 @@ buildRequest ri = do
          (connectSecretKey ci')
          timeStamp
          (riRegion ri')
-          Nothing
+          (riPresignExpirySecs ri')
          Nothing

  -- Cases to handle:
  --
+  -- 0. Handle presign URL case.
+  --
  -- 1. Connection is secure: use unsigned payload
  --
  -- 2. Insecure connection, streaming signature is enabled via use of
@ -155,33 +194,44 @@ buildRequest ri = do
  -- 3. Insecure connection, non-conduit payload: compute payload
  -- sha256hash, buffer request in memory and perform request.

-  -- case 2 from above.
  if
-      | isStreamingPayload (riPayload ri')
-          && (not $ connectIsSecure ci') -> do
-        (pLen, pSrc) <- case riPayload ri of
-          PayloadC l src -> return (l, src)
-          _ -> throwIO MErrVUnexpectedPayload
-        let reqFn = signV4Stream pLen sp baseRequest
-        return $ reqFn pSrc
-      | otherwise -> do
-        -- case 1 described above.
-        sp' <-
-          if
-              | connectIsSecure ci' -> return sp
-              -- case 3 described above.
-              | otherwise -> do
-                pHash <- getPayloadSHA256Hash $ riPayload ri'
-                return $ sp {spPayloadHash = Just pHash}
+      | isJust (riPresignExpirySecs ri') ->
+        -- case 0 from above.
+        do
+          let signPairs = signV4 sp baseRequest
+              qpToAdd = (fmap . fmap) Just signPairs
+              existingQueryParams = HT.parseQuery (NC.queryString baseRequest)
+              updatedQueryParams = existingQueryParams ++ qpToAdd
+          return $ NClient.setQueryString updatedQueryParams baseRequest
+      | isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') ->
+        -- case 2 from above.
+        do
+          (pLen, pSrc) <- case riPayload ri of
+            PayloadC l src -> return (l, src)
+            _ -> throwIO MErrVUnexpectedPayload
+          let reqFn = signV4Stream pLen sp baseRequest
+          return $ reqFn pSrc
+      | otherwise ->
+        do
+          sp' <-
+            if
+                | connectIsSecure ci' ->
+                  -- case 1 described above.
+                  return sp
+                | otherwise ->
+                  -- case 3 described above.
+                  do
+                    pHash <- getPayloadSHA256Hash $ riPayload ri'
+                    return $ sp {spPayloadHash = Just pHash}

-        let signHeaders = signV4 sp' baseRequest
-        return $
-          baseRequest
-            { NC.requestHeaders =
-                NC.requestHeaders baseRequest
-                  ++ mkHeaderFromPairs signHeaders,
-              NC.requestBody = getRequestBody (riPayload ri')
-            }
+          let signHeaders = signV4 sp' baseRequest
+          return $
+            baseRequest
+              { NC.requestHeaders =
+                  NC.requestHeaders baseRequest
+                    ++ mkHeaderFromPairs signHeaders,
+                NC.requestBody = getRequestBody (riPayload ri')
+              }

 retryAPIRequest :: Minio a -> Minio a
 retryAPIRequest apiCall = do
--- a/src/Network/Minio/APICommon.hs
+++ b/src/Network/Minio/APICommon.hs
@ -20,6 +20,7 @@ import qualified Conduit as C
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LB
 import Data.Conduit.Binary (sourceHandleRange)
+import qualified Data.Text as T
 import Lib.Prelude
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
@ -70,3 +71,10 @@ mkStreamingPayload payload =
 isStreamingPayload :: Payload -> Bool
 isStreamingPayload (PayloadC _ _) = True
 isStreamingPayload _ = False
+
+-- | Checks if the connect info is for Amazon S3.
+isAWSConnectInfo :: ConnectInfo -> Bool
+isAWSConnectInfo ci = ".amazonaws.com" `T.isSuffixOf` connectHost ci
+
+bucketHasPeriods :: Bucket -> Bool
+bucketHasPeriods b = isJust $ T.find (== '.') b
--- a/src/Network/Minio/Data.hs
+++ b/src/Network/Minio/Data.hs
@ -49,6 +49,7 @@ import Network.HTTP.Types
  )
 import qualified Network.HTTP.Types as HT
 import Network.Minio.Data.Crypto
+import Network.Minio.Data.Time
 import Network.Minio.Errors
 import System.Directory (doesFileExist, getHomeDirectory)
 import qualified System.Environment as Env
@ -79,20 +80,20 @@ maxMultipartParts = 10000
 awsRegionMap :: H.HashMap Text Text
 awsRegionMap =
  H.fromList
-    [ ("us-east-1", "s3.amazonaws.com"),
-      ("us-east-2", "s3-us-east-2.amazonaws.com"),
-      ("us-west-1", "s3-us-west-1.amazonaws.com"),
-      ("us-west-2", "s3-us-west-2.amazonaws.com"),
-      ("ca-central-1", "s3-ca-central-1.amazonaws.com"),
-      ("ap-south-1", "s3-ap-south-1.amazonaws.com"),
-      ("ap-northeast-1", "s3-ap-northeast-1.amazonaws.com"),
-      ("ap-northeast-2", "s3-ap-northeast-2.amazonaws.com"),
-      ("ap-southeast-1", "s3-ap-southeast-1.amazonaws.com"),
-      ("ap-southeast-2", "s3-ap-southeast-2.amazonaws.com"),
-      ("eu-west-1", "s3-eu-west-1.amazonaws.com"),
-      ("eu-west-2", "s3-eu-west-2.amazonaws.com"),
-      ("eu-central-1", "s3-eu-central-1.amazonaws.com"),
-      ("sa-east-1", "s3-sa-east-1.amazonaws.com")
+    [ ("us-east-1", "s3.us-east-1.amazonaws.com"),
+      ("us-east-2", "s3.us-east-2.amazonaws.com"),
+      ("us-west-1", "s3.us-west-1.amazonaws.com"),
+      ("us-west-2", "s3.us-west-2.amazonaws.com"),
+      ("ca-central-1", "s3.ca-central-1.amazonaws.com"),
+      ("ap-south-1", "s3.ap-south-1.amazonaws.com"),
+      ("ap-northeast-1", "s3.ap-northeast-1.amazonaws.com"),
+      ("ap-northeast-2", "s3.ap-northeast-2.amazonaws.com"),
+      ("ap-southeast-1", "s3.ap-southeast-1.amazonaws.com"),
+      ("ap-southeast-2", "s3.ap-southeast-2.amazonaws.com"),
+      ("eu-west-1", "s3.eu-west-1.amazonaws.com"),
+      ("eu-west-2", "s3.eu-west-2.amazonaws.com"),
+      ("eu-central-1", "s3.eu-central-1.amazonaws.com"),
+      ("sa-east-1", "s3.sa-east-1.amazonaws.com")
    ]

 -- | Connection Info data type. To create a 'ConnectInfo' value,
@ -1022,7 +1023,8 @@ data S3ReqInfo = S3ReqInfo
    riPayload :: Payload,
    riPayloadHash :: Maybe ByteString,
    riRegion :: Maybe Region,
-    riNeedsLocation :: Bool
+    riNeedsLocation :: Bool,
+    riPresignExpirySecs :: Maybe UrlExpiry
  }

 defaultS3ReqInfo :: S3ReqInfo
@ -1037,16 +1039,13 @@ defaultS3ReqInfo =
    Nothing
    Nothing
    True
+    Nothing

 getS3Path :: Maybe Bucket -> Maybe Object -> ByteString
 getS3Path b o =
  let segments = map toUtf8 $ 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 = H.HashMap Bucket Region

 -- | The Minio Monad - all computations accessing object storage
--- a/src/Network/Minio/Data/Time.hs
+++ b/src/Network/Minio/Data/Time.hs
@ -21,6 +21,7 @@ module Network.Minio.Data.Time
    awsDateFormatBS,
    awsParseTime,
    iso8601TimeFormat,
+    UrlExpiry,
  )
 where

@ -28,6 +29,10 @@ import Data.ByteString.Char8 (pack)
 import qualified Data.Time as Time
 import Lib.Prelude

+-- | 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
+
 awsTimeFormat :: UTCTime -> [Char]
 awsTimeFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"

--- a/src/Network/Minio/PresignedOperations.hs
+++ b/src/Network/Minio/PresignedOperations.hs
@ -42,13 +42,14 @@ import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import qualified Data.Time as Time
 import Lib.Prelude
-import qualified Network.HTTP.Conduit as NC
+import qualified Network.HTTP.Client as NClient
 import qualified Network.HTTP.Types as HT
-import Network.HTTP.Types.Header (hHost)
+import Network.Minio.API (buildRequest)
 import Network.Minio.Data
 import Network.Minio.Data.Time
 import Network.Minio.Errors
 import Network.Minio.Sign.V4
+import Network.URI (uriToString)

 -- | Generate a presigned URL. This function allows for advanced usage
 -- - for simple cases prefer the `presigned*Url` functions.
@ -72,44 +73,22 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
    throwIO $
      MErrVInvalidUrlExpiry expiry

-  ci <- asks mcConnInfo
-
-  let hostHeader = (hHost, getHostAddr ci)
-      req =
-        NC.defaultRequest
-          { NC.method = method,
-            NC.secure = connectIsSecure ci,
-            NC.host = encodeUtf8 $ connectHost ci,
-            NC.port = connectPort ci,
-            NC.path = getS3Path bucket object,
-            NC.requestHeaders = hostHeader : extraHeaders,
-            NC.queryString = HT.renderQuery True extraQuery
+  let s3ri =
+        defaultS3ReqInfo
+          { riPresignExpirySecs = Just expiry,
+            riMethod = method,
+            riBucket = bucket,
+            riObject = object,
+            riRegion = region,
+            riQueryParams = extraQuery,
+            riHeaders = extraHeaders
          }
-  ts <- liftIO Time.getCurrentTime

-  let sp =
-        SignParams
-          (connectAccessKey ci)
-          (connectSecretKey ci)
-          ts
-          region
-          (Just expiry)
-          Nothing
-      signPairs = signV4 sp req
-      qpToAdd = (fmap . fmap) Just signPairs
-      queryStr =
-        HT.renderQueryBuilder
-          True
-          ((HT.parseQuery $ NC.queryString req) ++ qpToAdd)
-      scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
+  req <- buildRequest s3ri
+  let uri = NClient.getUri req
+      uriString = uriToString identity uri ""

-  return $
-    toStrictBS $
-      toLazyByteString $
-        scheme
-          <> byteString (getHostAddr ci)
-          <> byteString (getS3Path bucket object)
-          <> queryStr
+  return $ toUtf8 uriString

 -- | Generate a URL with authentication signature to PUT (upload) an
 -- object. Any extra headers if passed, are signed, and so they are
--- a/src/Network/Minio/Sign/V4.hs
+++ b/src/Network/Minio/Sign/V4.hs
@ -65,7 +65,7 @@ data SignParams = SignParams
    spSecretKey :: Text,
    spTimeStamp :: UTCTime,
    spRegion :: Maybe Text,
-    spExpirySecs :: Maybe Int,
+    spExpirySecs :: Maybe UrlExpiry,
    spPayloadHash :: Maybe ByteString
  }
  deriving (Show)
--- a/test/LiveServer.hs
+++ b/test/LiveServer.hs
@ -34,7 +34,6 @@ import qualified Network.HTTP.Types as HT
 import Network.Minio
 import Network.Minio.Data
 import Network.Minio.Data.Crypto
-import Network.Minio.PutObject
 import Network.Minio.S3API
 import Network.Minio.Utils
 import System.Directory (getTemporaryDirectory)