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

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

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 ci' = ci {connectHost = host}
-
+      hostHeader = (hHost, getHostAddr ci')
-  let ri' =
+      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')
+      | isJust (riPresignExpirySecs ri') ->
-          && (not $ connectIsSecure ci') -> do
+        -- case 0 from above.
-        (pLen, pSrc) <- case riPayload ri of
+        do
-          PayloadC l src -> return (l, src)
+          let signPairs = signV4 sp baseRequest
-          _ -> throwIO MErrVUnexpectedPayload
+              qpToAdd = (fmap . fmap) Just signPairs
-        let reqFn = signV4Stream pLen sp baseRequest
+              existingQueryParams = HT.parseQuery (NC.queryString baseRequest)
-        return $ reqFn pSrc
+              updatedQueryParams = existingQueryParams ++ qpToAdd
-      | otherwise -> do
+          return $ NClient.setQueryString updatedQueryParams baseRequest
-        -- case 1 described above.
+      | isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') ->
-        sp' <-
+        -- case 2 from above.
-          if
+        do
-              | connectIsSecure ci' -> return sp
+          (pLen, pSrc) <- case riPayload ri of
-              -- case 3 described above.
+            PayloadC l src -> return (l, src)
-              | otherwise -> do
+            _ -> throwIO MErrVUnexpectedPayload
-                pHash <- getPayloadSHA256Hash $ riPayload ri'
+          let reqFn = signV4Stream pLen sp baseRequest
-                return $ sp {spPayloadHash = Just pHash}
+          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
+          let signHeaders = signV4 sp' baseRequest
-        return $
+          return $
-          baseRequest
+            baseRequest
-            { NC.requestHeaders =
+              { NC.requestHeaders =
-                NC.requestHeaders baseRequest
+                  NC.requestHeaders baseRequest
-                  ++ mkHeaderFromPairs signHeaders,
+                    ++ mkHeaderFromPairs signHeaders,
-              NC.requestBody = getRequestBody (riPayload ri')
+                NC.requestBody = getRequestBody (riPayload ri')
-            }
+              }
 
 retryAPIRequest :: Minio a -> Minio a
 retryAPIRequest apiCall = do

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

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-1", "s3.us-east-1.amazonaws.com"),
-      ("us-east-2", "s3-us-east-2.amazonaws.com"),
+      ("us-east-2", "s3.us-east-2.amazonaws.com"),
-      ("us-west-1", "s3-us-west-1.amazonaws.com"),
+      ("us-west-1", "s3.us-west-1.amazonaws.com"),
-      ("us-west-2", "s3-us-west-2.amazonaws.com"),
+      ("us-west-2", "s3.us-west-2.amazonaws.com"),
-      ("ca-central-1", "s3-ca-central-1.amazonaws.com"),
+      ("ca-central-1", "s3.ca-central-1.amazonaws.com"),
-      ("ap-south-1", "s3-ap-south-1.amazonaws.com"),
+      ("ap-south-1", "s3.ap-south-1.amazonaws.com"),
-      ("ap-northeast-1", "s3-ap-northeast-1.amazonaws.com"),
+      ("ap-northeast-1", "s3.ap-northeast-1.amazonaws.com"),
-      ("ap-northeast-2", "s3-ap-northeast-2.amazonaws.com"),
+      ("ap-northeast-2", "s3.ap-northeast-2.amazonaws.com"),
-      ("ap-southeast-1", "s3-ap-southeast-1.amazonaws.com"),
+      ("ap-southeast-1", "s3.ap-southeast-1.amazonaws.com"),
-      ("ap-southeast-2", "s3-ap-southeast-2.amazonaws.com"),
+      ("ap-southeast-2", "s3.ap-southeast-2.amazonaws.com"),
-      ("eu-west-1", "s3-eu-west-1.amazonaws.com"),
+      ("eu-west-1", "s3.eu-west-1.amazonaws.com"),
-      ("eu-west-2", "s3-eu-west-2.amazonaws.com"),
+      ("eu-west-2", "s3.eu-west-2.amazonaws.com"),
-      ("eu-central-1", "s3-eu-central-1.amazonaws.com"),
+      ("eu-central-1", "s3.eu-central-1.amazonaws.com"),
-      ("sa-east-1", "s3-sa-east-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

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"
 

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 s3ri =
-
+        defaultS3ReqInfo
-  let hostHeader = (hHost, getHostAddr ci)
+          { riPresignExpirySecs = Just expiry,
-      req =
+            riMethod = method,
-        NC.defaultRequest
+            riBucket = bucket,
-          { NC.method = method,
+            riObject = object,
-            NC.secure = connectIsSecure ci,
+            riRegion = region,
-            NC.host = encodeUtf8 $ connectHost ci,
+            riQueryParams = extraQuery,
-            NC.port = connectPort ci,
+            riHeaders = extraHeaders
-            NC.path = getS3Path bucket object,
-            NC.requestHeaders = hostHeader : extraHeaders,
-            NC.queryString = HT.renderQuery True extraQuery
           }
-  ts <- liftIO Time.getCurrentTime
 
-  let sp =
+  req <- buildRequest s3ri
-        SignParams
+  let uri = NClient.getUri req
-          (connectAccessKey ci)
+      uriString = uriToString identity uri ""
-          (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
 
-  return $
+  return $ toUtf8 uriString
-    toStrictBS $
-      toLazyByteString $
-        scheme
-          <> byteString (getHostAddr ci)
-          <> byteString (getS3Path bucket object)
-          <> queryStr
 
 -- | Generate a URL with authentication signature to PUT (upload) an
 -- object. Any extra headers if passed, are signed, and so they are

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)

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)