Add support for AssumeRole STS API (#188)

This change adds support for requesting temporary object storage
credentials using the STS API. Some breaking changes are introduced to
enable this support:

- `Credentials` type has been removed. Use the `CredentialValue` type
instead. Corresponding to this the type signature for `setCreds` has
changed, though the functionality is the same.
- The type alias `Provider` has been renamed to `CredentialLoader` to
avoid naming confusion.

CHANGELOG.md

@@ -3,8 +3,18 @@ Changelog
 
 ## Version 1.7.0 -- Unreleased
 
-* Fix data type `EventMessage` to not export partial fields
+* Fix data type `EventMessage` to not export partial fields (#179)
-* Bump up min bound on time dep and fix deprecation warnings.
+* Bump up min bound on time dep and fix deprecation warnings (#181)
+* Add `dev` flag to cabal for building with warnings as errors (#182)
+* Fix AWS region map (#185)
+* Fix XML generator tests (#187)
+* Add support for STS Assume Role API (#188)
+
+### Breaking changes in 1.7.0
+
+* `Credentials` type has been removed. Use `CredentialValue` instead.
+* `Provider` type has been replaced with `CredentialLoader`.
+* `EventMessage` data type is updated.
 
 ## Version 1.6.0
 

README.md

@@ -1,4 +1,4 @@
-# MinIO Haskell Client SDK for Amazon S3 Compatible Cloud Storage [![Build Status](https://travis-ci.org/minio/minio-hs.svg?branch=master)](https://travis-ci.org/minio/minio-hs)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io)
+# MinIO Haskell Client SDK for Amazon S3 Compatible Cloud Storage [![CI](https://github.com/minio/minio-hs/actions/workflows/ci.yml/badge.svg)](https://github.com/minio/minio-hs/actions/workflows/ci.yml)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io)
 
 The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min.io) and any Amazon S3 compatible object storage.
 

examples/AssumeRole.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2022 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -15,19 +15,33 @@
 --
 {-# LANGUAGE OverloadedStrings #-}
 
-import Network.Minio.Credentials
+import Control.Monad.IO.Class (liftIO)
+import Network.Minio
 import Prelude
 
 main :: IO ()
 main = do
-  res <-
+  -- Use play credentials for example.
-    retrieveCredentials
+  let assumeRole =
-      $ STSAssumeRole
+        STSAssumeRole
-        "https://play.min.io"
+          ( CredentialValue
-        ( CredentialValue
+              "Q3AM3UQ867SPQQA43P2F"
-            "Q3AM3UQ867SPQQA43P2F"
+              "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"
-            "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"
+              Nothing
-            Nothing
+          )
-        )
+          $ defaultSTSAssumeRoleOptions
-      $ defaultSTSAssumeRoleOptions {saroLocation = Just "us-east-1"}
+            { saroLocation = Just "us-east-1",
+              saroEndpoint = Just "https://play.min.io:9000"
+            }
+
+  -- Retrieve temporary credentials and print them.
+  cv <- requestSTSCredential assumeRole
+  print $ "Temporary credentials" ++ show (credentialValueText $ fst cv)
+  print $ "Expiry" ++ show (snd cv)
+
+  -- Configure 'ConnectInfo' to request temporary credentials on demand.
+  ci <- setSTSCredential assumeRole "https://play.min.io"
+  res <- runMinio ci $ do
+    buckets <- listBuckets
+    liftIO $ print $ "Top 5 buckets: " ++ show (take 5 buckets)
   print res

minio-hs.cabal

@@ -77,8 +77,6 @@ common base-settings
                      , RankNTypes
                      , ScopedTypeVariables
                      , TupleSections
-                     , TypeFamilies
-
 
   other-modules:       Lib.Prelude
                      , Network.Minio.API
@@ -97,7 +95,11 @@ common base-settings
                      , Network.Minio.Utils
                      , Network.Minio.XmlGenerator
                      , Network.Minio.XmlParser
+                     , Network.Minio.XmlCommon
                      , Network.Minio.JsonParser
+                     , Network.Minio.Credentials.Types
+                     , Network.Minio.Credentials.AssumeRole
+                     , Network.Minio.Credentials
 
   mixins:              base hiding (Prelude)
                      , relude (Relude as Prelude)
@@ -142,7 +144,6 @@ library
   exposed-modules:     Network.Minio
                      , Network.Minio.AdminAPI
                      , Network.Minio.S3API
-                     , Network.Minio.Credentials
 
 Flag live-test
   Description: Build the test suite that runs against a live MinIO server
@@ -164,6 +165,7 @@ test-suite minio-hs-live-server-test
                      , Network.Minio.Utils.Test
                      , Network.Minio.XmlGenerator.Test
                      , Network.Minio.XmlParser.Test
+                     , Network.Minio.Credentials
   build-depends:       minio-hs
                      , raw-strings-qq
                      , tasty
@@ -197,6 +199,7 @@ test-suite minio-hs-test
                      , Network.Minio.Utils.Test
                      , Network.Minio.XmlGenerator.Test
                      , Network.Minio.XmlParser.Test
+                     , Network.Minio.Credentials
 
 Flag examples
   Description: Build the examples

src/Network/Minio.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -16,7 +16,7 @@
 
 -- |
 -- Module:      Network.Minio
--- Copyright:   (c) 2017-2019 MinIO Dev Team
+-- Copyright:   (c) 2017-2023 MinIO Dev Team
 -- License:     Apache 2.0
 -- Maintainer:  MinIO Dev Team <dev@min.io>
 --
@@ -24,13 +24,17 @@
 -- storage servers like MinIO.
 module Network.Minio
   ( -- * Credentials
-    Credentials (..),
+    CredentialValue (..),
+    credentialValueText,
+    AccessKey (..),
+    SecretKey (..),
+    SessionToken (..),
 
-    -- ** Credential providers
+    -- ** Credential Loaders
 
-    -- | Run actions that retrieve 'Credentials' from the environment or
+    -- | Run actions that retrieve 'CredentialValue's from the environment or
     -- files or other custom sources.
-    Provider,
+    CredentialLoader,
     fromAWSConfigFile,
     fromAWSEnv,
     fromMinioEnv,
@@ -54,6 +58,15 @@ module Network.Minio
     awsCI,
     gcsCI,
 
+    -- ** STS Credential types
+    STSAssumeRole (..),
+    STSAssumeRoleOptions (..),
+    defaultSTSAssumeRoleOptions,
+    requestSTSCredential,
+    setSTSCredential,
+    ExpiryTime (..),
+    STSCredentialProvider,
+
     -- * Minio Monad
 
     ----------------
@@ -225,14 +238,15 @@ This module exports the high-level MinIO API for object storage.
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.Combinators as CC
+import Network.Minio.API
 import Network.Minio.CopyObject
+import Network.Minio.Credentials
 import Network.Minio.Data
 import Network.Minio.Errors
 import Network.Minio.ListOps
 import Network.Minio.PutObject
 import Network.Minio.S3API
 import Network.Minio.SelectAPI
-import Network.Minio.Utils
 
 -- | Lists buckets.
 listBuckets :: Minio [BucketInfo]

src/Network/Minio/API.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -26,6 +26,7 @@ module Network.Minio.API
     checkBucketNameValidity,
     isValidObjectName,
     checkObjectNameValidity,
+    requestSTSCredential,
   )
 where
 
@@ -34,7 +35,6 @@ import Control.Retry
     limitRetriesByCumulativeDelay,
     retrying,
   )
-import qualified Data.ByteArray as BA
 import qualified Data.ByteString as B
 import qualified Data.Char as C
 import qualified Data.Conduit as C
@@ -42,6 +42,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 Network.HTTP.Client (defaultManagerSettings)
 import qualified Network.HTTP.Client as NClient
 import Network.HTTP.Conduit (Response)
 import qualified Network.HTTP.Conduit as NC
@@ -49,6 +50,7 @@ import Network.HTTP.Types (simpleQueryToQuery)
 import qualified Network.HTTP.Types as HT
 import Network.HTTP.Types.Header (hHost)
 import Network.Minio.APICommon
+import Network.Minio.Credentials
 import Network.Minio.Data
 import Network.Minio.Errors
 import Network.Minio.Sign.V4
@@ -145,6 +147,20 @@ getHostPathRegion ri = do
           else return pathStyle
         )
 
+-- | requestSTSCredential requests temporary credentials using the Security Token
+-- Service API. The returned credential will include a populated 'SessionToken'
+-- and an 'ExpiryTime'.
+requestSTSCredential :: STSCredentialProvider p => p -> IO (CredentialValue, ExpiryTime)
+requestSTSCredential p = do
+  endpoint <- maybe (throwIO $ MErrValidation MErrVSTSEndpointNotFound) return $ getSTSEndpoint p
+  let endPt = NC.parseRequest_ $ toString endpoint
+      settings
+        | NC.secure endPt = NC.tlsManagerSettings
+        | otherwise = defaultManagerSettings
+
+  mgr <- NC.newManager settings
+  liftIO $ retrieveSTSCredentials p ("", 0, False) mgr
+
 buildRequest :: S3ReqInfo -> Minio NC.Request
 buildRequest ri = do
   maybe (return ()) checkBucketNameValidity $ riBucket ri
@@ -175,10 +191,14 @@ buildRequest ri = do
 
   timeStamp <- liftIO Time.getCurrentTime
 
+  mgr <- asks mcConnManager
+  cv <- liftIO $ getCredential (connectCreds ci') (getEndpoint ci') mgr
+
   let sp =
         SignParams
-          (connectAccessKey ci')
+          (coerce $ cvAccessKey cv)
-          (BA.convert (encodeUtf8 $ connectSecretKey ci' :: ByteString))
+          (coerce $ cvSecretKey cv)
+          (coerce $ cvSessionToken cv)
           ServiceS3
           timeStamp
           (riRegion ri')

src/Network/Minio/AdminAPI.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2018-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -70,7 +70,6 @@ import Data.Aeson
   )
 import qualified Data.Aeson as A
 import Data.Aeson.Types (typeMismatch)
-import qualified Data.ByteArray as BA
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as T
@@ -81,6 +80,7 @@ import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
 import Network.HTTP.Types.Header (hHost)
 import Network.Minio.APICommon
+import Network.Minio.Credentials
 import Network.Minio.Data
 import Network.Minio.Errors
 import Network.Minio.Sign.V4
@@ -666,6 +666,9 @@ buildAdminRequest areq = do
 
   timeStamp <- liftIO getCurrentTime
 
+  mgr <- asks mcConnManager
+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr
+
   let hostHeader = (hHost, getHostAddr ci)
       newAreq =
         areq
@@ -678,8 +681,9 @@ buildAdminRequest areq = do
       signReq = toRequest ci newAreq
       sp =
         SignParams
-          (connectAccessKey ci)
+          (coerce $ cvAccessKey cv)
-          (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString))
+          (coerce $ cvSecretKey cv)
+          (coerce $ cvSessionToken cv)
           ServiceS3
           timeStamp
           Nothing

src/Network/Minio/Credentials.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017-2022 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -16,129 +16,62 @@
 
 module Network.Minio.Credentials
   ( CredentialValue (..),
-    CredentialProvider (..),
+    credentialValueText,
-    AccessKey,
+    STSCredentialProvider (..),
-    SecretKey,
+    AccessKey (..),
-    SessionToken,
+    SecretKey (..),
+    SessionToken (..),
+    ExpiryTime (..),
+    STSCredentialStore,
+    initSTSCredential,
+    getSTSCredential,
+    Creds (..),
+    getCredential,
+    Endpoint,
+
+    -- * STS Assume Role
     defaultSTSAssumeRoleOptions,
     STSAssumeRole (..),
     STSAssumeRoleOptions (..),
   )
 where
 
-import qualified Data.Time as Time
+import Data.Time (diffUTCTime, getCurrentTime)
-import Data.Time.Units (Second)
-import Network.HTTP.Client (RequestBody (RequestBodyBS))
 import qualified Network.HTTP.Client as NC
-import qualified Network.HTTP.Client.TLS as NC
+import Network.Minio.Credentials.AssumeRole
-import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery)
+import Network.Minio.Credentials.Types
-import Network.HTTP.Types.Header (hHost)
+import qualified UnliftIO.MVar as M
-import Network.Minio.Data
-import Network.Minio.Data.Crypto (hashSHA256)
-import Network.Minio.Sign.V4
-import Network.Minio.Utils (httpLbs)
-import Network.Minio.XmlParser (parseSTSAssumeRoleResult)
 
-class CredentialProvider p where
+data STSCredentialStore = STSCredentialStore
-  retrieveCredentials :: p -> IO CredentialValue
+  { cachedCredentials :: M.MVar (CredentialValue, ExpiryTime),
-
+    refreshAction :: Endpoint -> NC.Manager -> IO (CredentialValue, ExpiryTime)
-stsVersion :: ByteString
-stsVersion = "2011-06-15"
-
-defaultDurationSeconds :: Second
-defaultDurationSeconds = 3600
-
-data STSAssumeRole = STSAssumeRole
-  { sarEndpoint :: Text,
-    sarCredentials :: CredentialValue,
-    sarOptions :: STSAssumeRoleOptions
   }
 
-data STSAssumeRoleOptions = STSAssumeRoleOptions
+initSTSCredential :: STSCredentialProvider p => p -> IO STSCredentialStore
-  { -- | Desired validity for the generated credentials.
+initSTSCredential p = do
-    saroDurationSeconds :: Maybe Second,
+  let action = retrieveSTSCredentials p
-    -- | IAM policy to apply for the generated credentials.
+  -- start with dummy credential, so that refresh happens for first request.
-    saroPolicyJSON :: Maybe ByteString,
+  now <- getCurrentTime
-    -- | Location is usually required for AWS.
+  mvar <- M.newMVar (CredentialValue mempty mempty mempty, coerce now)
-    saroLocation :: Maybe Text,
+  return $
-    saroRoleARN :: Maybe Text,
+    STSCredentialStore
-    saroRoleSessionName :: Maybe Text,
+      { cachedCredentials = mvar,
-    -- | Optional HTTP connection manager
+        refreshAction = action
-    saroHTTPManager :: Maybe NC.Manager
+      }
-  }
 
--- | Default STS Assume Role options
+getSTSCredential :: STSCredentialStore -> Endpoint -> NC.Manager -> IO (CredentialValue, Bool)
-defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions
+getSTSCredential store ep mgr = M.modifyMVar (cachedCredentials store) $ \cc@(v, expiry) -> do
-defaultSTSAssumeRoleOptions =
+  now <- getCurrentTime
-  STSAssumeRoleOptions
+  if diffUTCTime now (coerce expiry) > 0
-    { saroDurationSeconds = Just defaultDurationSeconds,
+    then do
-      saroPolicyJSON = Nothing,
+      res <- refreshAction store ep mgr
-      saroLocation = Nothing,
+      return (res, (fst res, True))
-      saroRoleARN = Nothing,
+    else return (cc, (v, False))
-      saroRoleSessionName = Nothing,
-      saroHTTPManager = Nothing
-    }
 
-instance CredentialProvider STSAssumeRole where
+data Creds
-  retrieveCredentials sar = do
+  = CredsStatic CredentialValue
-    -- Assemble STS request
+  | CredsSTS STSCredentialStore
-    let requiredParams =
-          [ ("Action", "AssumeRole"),
-            ("Version", stsVersion)
-          ]
-        opts = sarOptions sar
-        durSecs :: Int =
-          fromIntegral $
-            fromMaybe defaultDurationSeconds $
-              saroDurationSeconds opts
-        otherParams =
-          [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts,
-            ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts,
-            Just ("DurationSeconds", show durSecs),
-            ("Policy",) <$> saroPolicyJSON opts
-          ]
-        parameters = requiredParams ++ catMaybes otherParams
-        (host, port, isSecure) =
-          let endPt = NC.parseRequest_ $ toString $ sarEndpoint sar
-           in (NC.host endPt, NC.port endPt, NC.secure endPt)
-        reqBody = renderSimpleQuery False parameters
-        req =
-          NC.defaultRequest
-            { NC.host = host,
-              NC.port = port,
-              NC.secure = isSecure,
-              NC.method = methodPost,
-              NC.requestHeaders =
-                [ (hHost, getHostHeader (host, port)),
-                  (hContentType, "application/x-www-form-urlencoded")
-                ],
-              NC.requestBody = RequestBodyBS reqBody
-            }
 
-    -- Sign the STS request.
+getCredential :: Creds -> Endpoint -> NC.Manager -> IO CredentialValue
-    timeStamp <- liftIO Time.getCurrentTime
+getCredential (CredsStatic v) _ _ = return v
-    let sp =
+getCredential (CredsSTS s) ep mgr = fst <$> getSTSCredential s ep mgr
-          SignParams
-            { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar,
-              spSecretKey = coerce $ cvSecretKey $ sarCredentials sar,
-              spService = ServiceSTS,
-              spTimeStamp = timeStamp,
-              spRegion = saroLocation opts,
-              spExpirySecs = Nothing,
-              spPayloadHash = Just $ hashSHA256 reqBody
-            }
-        signHeaders = signV4 sp req
-        signedReq =
-          req
-            { NC.requestHeaders = NC.requestHeaders req ++ signHeaders
-            }
-        settings = bool NC.defaultManagerSettings NC.tlsManagerSettings isSecure
-
-    -- Make the STS request
-    mgr <- maybe (NC.newManager settings) return $ saroHTTPManager opts
-    resp <- httpLbs signedReq mgr
-    result <-
-      parseSTSAssumeRoleResult
-        (toStrict $ NC.responseBody resp)
-        "https://sts.amazonaws.com/doc/2011-06-15/"
-    return $ arcCredentials $ arrRoleCredentials result

src/Network/Minio/Credentials/AssumeRole.hs

@@ -0,0 +1,264 @@
+--
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+
+module Network.Minio.Credentials.AssumeRole where
+
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text as T
+import qualified Data.Time as Time
+import Data.Time.Units (Second)
+import Lib.Prelude (UTCTime, throwIO)
+import Network.HTTP.Client (RequestBody (RequestBodyBS))
+import qualified Network.HTTP.Client as NC
+import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery)
+import Network.HTTP.Types.Header (hHost)
+import Network.Minio.Credentials.Types
+import Network.Minio.Data.Crypto (hashSHA256)
+import Network.Minio.Errors (MErrV (..))
+import Network.Minio.Sign.V4
+import Network.Minio.Utils (getHostHeader, httpLbs)
+import Network.Minio.XmlCommon
+import Text.XML.Cursor hiding (bool)
+
+stsVersion :: ByteString
+stsVersion = "2011-06-15"
+
+defaultDurationSeconds :: Second
+defaultDurationSeconds = 3600
+
+-- | Assume Role API argument.
+data STSAssumeRole = STSAssumeRole
+  { -- | Credentials to use in the AssumeRole STS API.
+    sarCredentials :: CredentialValue,
+    -- | Optional settings.
+    sarOptions :: STSAssumeRoleOptions
+  }
+
+-- | Options for STS Assume Role API.
+data STSAssumeRoleOptions = STSAssumeRoleOptions
+  { -- | STS endpoint to which the request will be made. For MinIO, this is the
+    -- same as the server endpoint. For AWS, this has to be the Security Token
+    -- Service endpoint. If using with 'setSTSCredential', this option can be
+    -- left as 'Nothing' and the endpoint in 'ConnectInfo' will be used.
+    saroEndpoint :: Maybe Text,
+    -- | Desired validity for the generated credentials.
+    saroDurationSeconds :: Maybe Second,
+    -- | IAM policy to apply for the generated credentials.
+    saroPolicyJSON :: Maybe ByteString,
+    -- | Location is usually required for AWS.
+    saroLocation :: Maybe Text,
+    saroRoleARN :: Maybe Text,
+    saroRoleSessionName :: Maybe Text
+  }
+
+-- | Default STS Assume Role options - all options are Nothing, except for
+-- duration which is set to 1 hour.
+defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions
+defaultSTSAssumeRoleOptions =
+  STSAssumeRoleOptions
+    { saroEndpoint = Nothing,
+      saroDurationSeconds = Just 3600,
+      saroPolicyJSON = Nothing,
+      saroLocation = Nothing,
+      saroRoleARN = Nothing,
+      saroRoleSessionName = Nothing
+    }
+
+data AssumeRoleCredentials = AssumeRoleCredentials
+  { arcCredentials :: CredentialValue,
+    arcExpiration :: UTCTime
+  }
+  deriving stock (Show, Eq)
+
+data AssumeRoleResult = AssumeRoleResult
+  { arrSourceIdentity :: Text,
+    arrAssumedRoleArn :: Text,
+    arrAssumedRoleId :: Text,
+    arrRoleCredentials :: AssumeRoleCredentials
+  }
+  deriving stock (Show, Eq)
+
+-- | parseSTSAssumeRoleResult parses an XML response of the following form:
+--
+-- <AssumeRoleResponse xmlns="https://sts.amazonaws.com/doc/2011-06-15/">
+--   <AssumeRoleResult>
+--   <SourceIdentity>Alice</SourceIdentity>
+--     <AssumedRoleUser>
+--       <Arn>arn:aws:sts::123456789012:assumed-role/demo/TestAR</Arn>
+--       <AssumedRoleId>ARO123EXAMPLE123:TestAR</AssumedRoleId>
+--     </AssumedRoleUser>
+--     <Credentials>
+--       <AccessKeyId>ASIAIOSFODNN7EXAMPLE</AccessKeyId>
+--       <SecretAccessKey>wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY</SecretAccessKey>
+--       <SessionToken>
+--        AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW
+--        LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd
+--        QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU
+--        9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz
+--        +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA==
+--       </SessionToken>
+--       <Expiration>2019-11-09T13:34:41Z</Expiration>
+--     </Credentials>
+--     <PackedPolicySize>6</PackedPolicySize>
+--   </AssumeRoleResult>
+--   <ResponseMetadata>
+--     <RequestId>c6104cbe-af31-11e0-8154-cbc7ccf896c7</RequestId>
+--   </ResponseMetadata>
+-- </AssumeRoleResponse>
+parseSTSAssumeRoleResult :: MonadIO m => ByteString -> Text -> m AssumeRoleResult
+parseSTSAssumeRoleResult xmldata namespace = do
+  r <- parseRoot $ LB.fromStrict xmldata
+  let s3Elem' = s3Elem namespace
+      sourceIdentity =
+        T.concat $
+          r
+            $/ s3Elem' "AssumeRoleResult"
+            &/ s3Elem' "SourceIdentity"
+            &/ content
+      roleArn =
+        T.concat $
+          r
+            $/ s3Elem' "AssumeRoleResult"
+            &/ s3Elem' "AssumedRoleUser"
+            &/ s3Elem' "Arn"
+            &/ content
+      roleId =
+        T.concat $
+          r
+            $/ s3Elem' "AssumeRoleResult"
+            &/ s3Elem' "AssumedRoleUser"
+            &/ s3Elem' "AssumedRoleId"
+            &/ content
+
+      convSB :: Text -> BA.ScrubbedBytes
+      convSB = BA.convert . (encodeUtf8 :: Text -> ByteString)
+
+      credsInfo = do
+        cr <-
+          maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $
+            listToMaybe $
+              r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials"
+        let cur = fromNode $ node cr
+        return
+          ( CredentialValue
+              { cvAccessKey =
+                  coerce $
+                    T.concat $
+                      cur $/ s3Elem' "AccessKeyId" &/ content,
+                cvSecretKey =
+                  coerce $
+                    convSB $
+                      T.concat $
+                        cur
+                          $/ s3Elem' "SecretAccessKey"
+                          &/ content,
+                cvSessionToken =
+                  Just $
+                    coerce $
+                      convSB $
+                        T.concat $
+                          cur
+                            $/ s3Elem' "SessionToken"
+                            &/ content
+              },
+            T.concat $ cur $/ s3Elem' "Expiration" &/ content
+          )
+  creds <- either throwIO pure credsInfo
+  expiry <- parseS3XMLTime $ snd creds
+  let roleCredentials =
+        AssumeRoleCredentials
+          { arcCredentials = fst creds,
+            arcExpiration = expiry
+          }
+  return
+    AssumeRoleResult
+      { arrSourceIdentity = sourceIdentity,
+        arrAssumedRoleArn = roleArn,
+        arrAssumedRoleId = roleId,
+        arrRoleCredentials = roleCredentials
+      }
+
+instance STSCredentialProvider STSAssumeRole where
+  getSTSEndpoint = saroEndpoint . sarOptions
+  retrieveSTSCredentials sar (host', port', isSecure') mgr = do
+    -- Assemble STS request
+    let requiredParams =
+          [ ("Action", "AssumeRole"),
+            ("Version", stsVersion)
+          ]
+        opts = sarOptions sar
+
+        durSecs :: Int =
+          fromIntegral $
+            fromMaybe defaultDurationSeconds $
+              saroDurationSeconds opts
+        otherParams =
+          [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts,
+            ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts,
+            Just ("DurationSeconds", show durSecs),
+            ("Policy",) <$> saroPolicyJSON opts
+          ]
+        parameters = requiredParams ++ catMaybes otherParams
+        (host, port, isSecure) =
+          case getSTSEndpoint sar of
+            Just ep ->
+              let endPt = NC.parseRequest_ $ toString ep
+               in (NC.host endPt, NC.port endPt, NC.secure endPt)
+            Nothing -> (host', port', isSecure')
+        reqBody = renderSimpleQuery False parameters
+        req =
+          NC.defaultRequest
+            { NC.host = host,
+              NC.port = port,
+              NC.secure = isSecure,
+              NC.method = methodPost,
+              NC.requestHeaders =
+                [ (hHost, getHostHeader (host, port)),
+                  (hContentType, "application/x-www-form-urlencoded")
+                ],
+              NC.requestBody = RequestBodyBS reqBody
+            }
+
+    -- Sign the STS request.
+    timeStamp <- liftIO Time.getCurrentTime
+    let sp =
+          SignParams
+            { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar,
+              spSecretKey = coerce $ cvSecretKey $ sarCredentials sar,
+              spSessionToken = coerce $ cvSessionToken $ sarCredentials sar,
+              spService = ServiceSTS,
+              spTimeStamp = timeStamp,
+              spRegion = saroLocation opts,
+              spExpirySecs = Nothing,
+              spPayloadHash = Just $ hashSHA256 reqBody
+            }
+        signHeaders = signV4 sp req
+        signedReq =
+          req
+            { NC.requestHeaders = NC.requestHeaders req ++ signHeaders
+            }
+
+    -- Make the STS request
+    resp <- httpLbs signedReq mgr
+    result <-
+      parseSTSAssumeRoleResult
+        (toStrict $ NC.responseBody resp)
+        "https://sts.amazonaws.com/doc/2011-06-15/"
+    return
+      ( arcCredentials $ arrRoleCredentials result,
+        coerce $ arcExpiration $ arrRoleCredentials result
+      )

src/Network/Minio/Credentials/Types.hs

@@ -0,0 +1,85 @@
+--
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Network.Minio.Credentials.Types where
+
+import qualified Data.ByteArray as BA
+import Lib.Prelude (UTCTime)
+import qualified Network.HTTP.Client as NC
+
+-- | Access Key type.
+newtype AccessKey = AccessKey {unAccessKey :: Text}
+  deriving stock (Show)
+  deriving newtype (Eq, IsString, Semigroup, Monoid)
+
+-- | Secret Key type - has a show instance that does not print the value.
+newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes}
+  deriving stock (Show)
+  deriving newtype (Eq, IsString, Semigroup, Monoid)
+
+-- | Session Token type - has a show instance that does not print the value.
+newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes}
+  deriving stock (Show)
+  deriving newtype (Eq, IsString, Semigroup, Monoid)
+
+-- | Object storage credential data type. It has support for the optional
+-- <https://docs.aws.amazon.com/IAM/latest/UserGuide/id_credentials_temp_use-resources.html
+-- SessionToken> for using temporary credentials requested via STS.
+--
+-- The show instance for this type does not print the value of secrets for
+-- security.
+data CredentialValue = CredentialValue
+  { cvAccessKey :: AccessKey,
+    cvSecretKey :: SecretKey,
+    cvSessionToken :: Maybe SessionToken
+  }
+  deriving stock (Eq, Show)
+
+scrubbedToText :: BA.ScrubbedBytes -> Text
+scrubbedToText =
+  let b2t :: ByteString -> Text
+      b2t = decodeUtf8
+      s2b :: BA.ScrubbedBytes -> ByteString
+      s2b = BA.convert
+   in b2t . s2b
+
+-- | Convert a 'CredentialValue' to a text tuple. Use this to output the
+-- credential to files or other programs.
+credentialValueText :: CredentialValue -> (Text, Text, Maybe Text)
+credentialValueText cv =
+  ( coerce $ cvAccessKey cv,
+    (scrubbedToText . coerce) $ cvSecretKey cv,
+    scrubbedToText . coerce <$> cvSessionToken cv
+  )
+
+-- | Endpoint represented by host, port and TLS enabled flag.
+type Endpoint = (ByteString, Int, Bool)
+
+-- | Typeclass for STS credential providers.
+class STSCredentialProvider p where
+  retrieveSTSCredentials ::
+    p ->
+    -- | STS Endpoint (host, port, isSecure)
+    Endpoint ->
+    NC.Manager ->
+    IO (CredentialValue, ExpiryTime)
+  getSTSEndpoint :: p -> Maybe Text
+
+-- | 'ExpiryTime' represents a time at which a credential expires.
+newtype ExpiryTime = ExpiryTime {unExpiryTime :: UTCTime}
+  deriving stock (Show)
+  deriving newtype (Eq)

src/Network/Minio/Data.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -34,9 +34,9 @@ import qualified Data.Aeson as A
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
-import Data.CaseInsensitive (mk)
 import qualified Data.HashMap.Strict as H
 import qualified Data.Ini as Ini
+import qualified Data.List as List
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import Data.Time (defaultTimeLocale, formatTime)
@@ -53,6 +53,7 @@ import Network.HTTP.Types
     hRange,
   )
 import qualified Network.HTTP.Types as HT
+import Network.Minio.Credentials
 import Network.Minio.Data.Crypto
   ( encodeToBase64,
     hashMD5ToBase64,
@@ -62,11 +63,12 @@ import Network.Minio.Errors
   ( MErrV (MErrVInvalidEncryptionKeyLength, MErrVMissingCredentials),
     MinioErr (..),
   )
+import Network.Minio.Utils
 import System.Directory (doesFileExist, getHomeDirectory)
 import qualified System.Environment as Env
 import System.FilePath.Posix (combine)
-import Text.XML (Name (Name))
 import qualified UnliftIO as U
+import qualified UnliftIO.MVar as UM
 
 -- | max obj size is 5TiB
 maxObjectSize :: Int64
@@ -131,14 +133,15 @@ awsRegionMap =
 data ConnectInfo = ConnectInfo
   { connectHost :: Text,
     connectPort :: Int,
-    connectAccessKey :: Text,
+    connectCreds :: Creds,
-    connectSecretKey :: Text,
     connectIsSecure :: Bool,
     connectRegion :: Region,
     connectAutoDiscoverRegion :: Bool,
     connectDisableTLSCertValidation :: Bool
   }
-  deriving stock (Eq, Show)
+
+getEndpoint :: ConnectInfo -> Endpoint
+getEndpoint ci = (encodeUtf8 $ connectHost ci, connectPort ci, connectIsSecure ci)
 
 instance IsString ConnectInfo where
   fromString str =
@@ -146,8 +149,7 @@ instance IsString ConnectInfo where
      in ConnectInfo
           { connectHost = TE.decodeUtf8 $ NC.host req,
             connectPort = NC.port req,
-            connectAccessKey = "",
+            connectCreds = CredsStatic $ CredentialValue mempty mempty mempty,
-            connectSecretKey = "",
             connectIsSecure = NC.secure req,
             connectRegion = "",
             connectAutoDiscoverRegion = True,
@@ -161,20 +163,21 @@ data Credentials = Credentials
   }
   deriving stock (Eq, Show)
 
--- | A Provider is an action that may return Credentials. Providers
+-- | A 'CredentialLoader' is an action that may return a 'CredentialValue'.
--- may be chained together using 'findFirst'.
+-- Loaders may be chained together using 'findFirst'.
-type Provider = IO (Maybe Credentials)
+type CredentialLoader = IO (Maybe CredentialValue)
 
--- | Combines the given list of providers, by calling each one in
+-- | Combines the given list of loaders, by calling each one in
--- order until Credentials are found.
+-- order until a 'CredentialValue' is returned.
-findFirst :: [Provider] -> Provider
+findFirst :: [CredentialLoader] -> IO (Maybe CredentialValue)
 findFirst [] = return Nothing
 findFirst (f : fs) = do
   c <- f
   maybe (findFirst fs) (return . Just) c
 
--- | This Provider loads `Credentials` from @~\/.aws\/credentials@
+-- | This action returns a 'CredentialValue' populated from
-fromAWSConfigFile :: Provider
+-- @~\/.aws\/credentials@
+fromAWSConfigFile :: CredentialLoader
 fromAWSConfigFile = do
   credsE <- runExceptT $ do
     homeDir <- lift getHomeDirectory
@@ -190,29 +193,28 @@ fromAWSConfigFile = do
       ExceptT $
         return $
           Ini.lookupValue "default" "aws_secret_access_key" ini
-    return $ Credentials akey skey
+    return $ CredentialValue (coerce akey) (fromString $ T.unpack skey) Nothing
   return $ either (const Nothing) Just credsE
 
--- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and
+-- | This action returns a 'CredentialValue` populated from @AWS_ACCESS_KEY_ID@
--- @AWS_SECRET_ACCESS_KEY@ environment variables.
+-- and @AWS_SECRET_ACCESS_KEY@ environment variables.
-fromAWSEnv :: Provider
+fromAWSEnv :: CredentialLoader
 fromAWSEnv = runMaybeT $ do
   akey <- MaybeT $ Env.lookupEnv "AWS_ACCESS_KEY_ID"
   skey <- MaybeT $ Env.lookupEnv "AWS_SECRET_ACCESS_KEY"
-  return $ Credentials (T.pack akey) (T.pack skey)
+  return $ CredentialValue (fromString akey) (fromString skey) Nothing
 
--- | This Provider loads `Credentials` from @MINIO_ACCESS_KEY@ and
+-- | This action returns a 'CredentialValue' populated from @MINIO_ACCESS_KEY@
--- @MINIO_SECRET_KEY@ environment variables.
+-- and @MINIO_SECRET_KEY@ environment variables.
-fromMinioEnv :: Provider
+fromMinioEnv :: CredentialLoader
 fromMinioEnv = runMaybeT $ do
   akey <- MaybeT $ Env.lookupEnv "MINIO_ACCESS_KEY"
   skey <- MaybeT $ Env.lookupEnv "MINIO_SECRET_KEY"
-  return $ Credentials (T.pack akey) (T.pack skey)
+  return $ CredentialValue (fromString akey) (fromString skey) Nothing
 
--- | setCredsFrom retrieves access credentials from the first
+-- | setCredsFrom retrieves access credentials from the first action in the
--- `Provider` form the given list that succeeds and sets it in the
+-- given list that succeeds and sets it in the 'ConnectInfo'.
--- `ConnectInfo`.
+setCredsFrom :: [CredentialLoader] -> ConnectInfo -> IO ConnectInfo
-setCredsFrom :: [Provider] -> ConnectInfo -> IO ConnectInfo
 setCredsFrom ps ci = do
   pMay <- findFirst ps
   maybe
@@ -220,14 +222,21 @@ setCredsFrom ps ci = do
     (return . (`setCreds` ci))
     pMay
 
--- | setCreds sets the given `Credentials` in the `ConnectInfo`.
+-- | setCreds sets the given `CredentialValue` in the `ConnectInfo`.
-setCreds :: Credentials -> ConnectInfo -> ConnectInfo
+setCreds :: CredentialValue -> ConnectInfo -> ConnectInfo
-setCreds (Credentials accessKey secretKey) connInfo =
+setCreds cv connInfo =
   connInfo
-    { connectAccessKey = accessKey,
+    { connectCreds = CredsStatic cv
-      connectSecretKey = secretKey
     }
 
+-- | 'setSTSCredential' configures `ConnectInfo` to retrieve temporary
+-- credentials via the STS API on demand. It is automatically refreshed on
+-- expiry.
+setSTSCredential :: STSCredentialProvider p => p -> ConnectInfo -> IO ConnectInfo
+setSTSCredential p ci = do
+  store <- initSTSCredential p
+  return ci {connectCreds = CredsSTS store}
+
 -- | Set the S3 region parameter in the `ConnectInfo`
 setRegion :: Region -> ConnectInfo -> ConnectInfo
 setRegion r connInfo =
@@ -248,12 +257,6 @@ isConnectInfoSecure = connectIsSecure
 disableTLSCertValidation :: ConnectInfo -> ConnectInfo
 disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}
 
-getHostHeader :: (ByteString, Int) -> ByteString
-getHostHeader (host, port) =
-  if port == 80 || port == 443
-    then host
-    else host <> ":" <> show port
-
 getHostAddr :: ConnectInfo -> ByteString
 getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort ci)
 
@@ -278,7 +281,7 @@ awsCI = "https://s3.amazonaws.com"
 -- ConnectInfo. Credentials are already filled in.
 minioPlayCI :: ConnectInfo
 minioPlayCI =
-  let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"
+  let playCreds = CredentialValue "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" Nothing
    in setCreds playCreds $
         setRegion
           "us-east-1"
@@ -380,24 +383,6 @@ data PutObjectOptions = PutObjectOptions
 defaultPutObjectOptions :: PutObjectOptions
 defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing
 
--- | If the given header name has the @X-Amz-Meta-@ prefix, it is
--- stripped and a Just is returned.
-userMetadataHeaderNameMaybe :: Text -> Maybe Text
-userMetadataHeaderNameMaybe k =
-  let prefix = T.toCaseFold "X-Amz-Meta-"
-      n = T.length prefix
-   in if T.toCaseFold (T.take n k) == prefix
-        then Just (T.drop n k)
-        else Nothing
-
-addXAmzMetaPrefix :: Text -> Text
-addXAmzMetaPrefix s
-  | isJust (userMetadataHeaderNameMaybe s) = s
-  | otherwise = "X-Amz-Meta-" <> s
-
-mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]
-mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y))
-
 pooToHeaders :: PutObjectOptions -> [HT.Header]
 pooToHeaders poo =
   userMetadata
@@ -437,6 +422,29 @@ data BucketInfo = BucketInfo
 -- | A type alias to represent a part-number for multipart upload
 type PartNumber = Int16
 
+-- | Select part sizes - the logic is that the minimum part-size will
+-- be 64MiB.
+selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
+selectPartSizes size =
+  uncurry (List.zip3 [1 ..]) $
+    List.unzip $
+      loop 0 size
+  where
+    ceil :: Double -> Int64
+    ceil = ceiling
+    partSize =
+      max
+        minPartSize
+        ( ceil $
+            fromIntegral size
+              / fromIntegral maxMultipartParts
+        )
+    m = partSize
+    loop st sz
+      | st > sz = []
+      | st + m >= sz = [(st, sz - st)]
+      | otherwise = (st, m) : loop (st + m) sz
+
 -- | A type alias to represent an upload-id for multipart upload
 type UploadId = Text
 
@@ -1016,47 +1024,6 @@ type Stats = Progress
 -- Select API Related Types End
 --------------------------------------------------------------------------
 
-----------------------------------------
--- Credentials Start
-----------------------------------------
-
-newtype AccessKey = AccessKey {unAccessKey :: Text}
-  deriving stock (Show)
-  deriving newtype (Eq, IsString)
-
-newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes}
-  deriving stock (Show)
-  deriving newtype (Eq, IsString)
-
-newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes}
-  deriving stock (Show)
-  deriving newtype (Eq, IsString)
-
-data CredentialValue = CredentialValue
-  { cvAccessKey :: AccessKey,
-    cvSecretKey :: SecretKey,
-    cvSessionToken :: Maybe SessionToken
-  }
-  deriving stock (Eq, Show)
-
-data AssumeRoleCredentials = AssumeRoleCredentials
-  { arcCredentials :: CredentialValue,
-    arcExpiration :: UTCTime
-  }
-  deriving stock (Show, Eq)
-
-data AssumeRoleResult = AssumeRoleResult
-  { arrSourceIdentity :: Text,
-    arrAssumedRoleArn :: Text,
-    arrAssumedRoleId :: Text,
-    arrRoleCredentials :: AssumeRoleCredentials
-  }
-  deriving stock (Show, Eq)
-
-----------------------------------------
--- Credentials End
-----------------------------------------
-
 -- | Represents different kinds of payload that are used with S3 API
 -- requests.
 data Payload
@@ -1202,9 +1169,22 @@ runMinioRes ci m = do
   conn <- liftIO $ connect ci
   runMinioResWith conn m
 
-s3Name :: Text -> Text -> Name
-s3Name ns s = Name s (Just ns) Nothing
-
 -- | Format as per RFC 1123.
 formatRFC1123 :: UTCTime -> T.Text
 formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
+
+lookupRegionCache :: Bucket -> Minio (Maybe Region)
+lookupRegionCache b = do
+  rMVar <- asks mcRegionMap
+  rMap <- UM.readMVar rMVar
+  return $ H.lookup b rMap
+
+addToRegionCache :: Bucket -> Region -> Minio ()
+addToRegionCache b region = do
+  rMVar <- asks mcRegionMap
+  UM.modifyMVar_ rMVar $ return . H.insert b region
+
+deleteFromRegionCache :: Bucket -> Minio ()
+deleteFromRegionCache b = do
+  rMVar <- asks mcRegionMap
+  UM.modifyMVar_ rMVar $ return . H.delete b

src/Network/Minio/Errors.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -49,6 +49,7 @@ data MErrV
   | MErrVInvalidEncryptionKeyLength
   | MErrVStreamingBodyUnexpectedEOF
   | MErrVUnexpectedPayload
+  | MErrVSTSEndpointNotFound
   deriving stock (Show, Eq)
 
 instance Exception MErrV

src/Network/Minio/PresignedOperations.hs

@@ -1,7 +1,5 @@
-{-# LANGUAGE CPP #-}
-
 --
--- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -15,6 +13,7 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE CPP #-}
 
 module Network.Minio.PresignedOperations
   ( UrlExpiry,
@@ -39,7 +38,6 @@ where
 
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Json
-import qualified Data.ByteArray as BA
 import Data.ByteString.Builder (byteString, toLazyByteString)
 import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
@@ -48,6 +46,7 @@ import Lib.Prelude
 import qualified Network.HTTP.Client as NClient
 import qualified Network.HTTP.Types as HT
 import Network.Minio.API (buildRequest)
+import Network.Minio.Credentials
 import Network.Minio.Data
 import Network.Minio.Data.Time
 import Network.Minio.Errors
@@ -300,6 +299,8 @@ presignedPostPolicy ::
 presignedPostPolicy p = do
   ci <- asks mcConnInfo
   signTime <- liftIO Time.getCurrentTime
+  mgr <- asks mcConnManager
+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr
 
   let extraConditions signParams =
         [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),
@@ -308,7 +309,7 @@ presignedPostPolicy p = do
             "x-amz-credential"
             ( T.intercalate
                 "/"
-                [ connectAccessKey ci,
+                [ coerce $ cvAccessKey cv,
                   decodeUtf8 $ credentialScope signParams
                 ]
             )
@@ -319,8 +320,9 @@ presignedPostPolicy p = do
           }
       sp =
         SignParams
-          (connectAccessKey ci)
+          (coerce $ cvAccessKey cv)
-          (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString))
+          (coerce $ cvSecretKey cv)
+          (coerce $ cvSessionToken cv)
           ServiceS3
           signTime
           (Just $ connectRegion ci)

src/Network/Minio/S3API.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -14,6 +14,14 @@
 -- limitations under the License.
 --
 
+-- |
+-- Module:      Network.Minio.S3API
+-- Copyright:   (c) 2017-2023 MinIO Dev Team
+-- License:     Apache 2.0
+-- Maintainer:  MinIO Dev Team <dev@min.io>
+--
+-- Lower-level API for S3 compatible object stores. Start with @Network.Minio@
+-- and use this only if needed.
 module Network.Minio.S3API
   ( Region,
     getLocation,

src/Network/Minio/Sign/V4.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -15,7 +15,16 @@
 --
 {-# LANGUAGE BangPatterns #-}
 
-module Network.Minio.Sign.V4 where
+module Network.Minio.Sign.V4
+  ( SignParams (..),
+    signV4QueryParams,
+    signV4,
+    signV4PostPolicy,
+    signV4Stream,
+    Service (..),
+    credentialScope,
+  )
+where
 
 import qualified Conduit as C
 import qualified Data.ByteArray as BA
@@ -23,6 +32,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Lazy as LB
+import Data.CaseInsensitive (mk)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Strict as Map
 import qualified Data.HashSet as Set
@@ -52,17 +62,6 @@ ignoredHeaders =
         H.hUserAgent
       ]
 
-data SignV4Data = SignV4Data
-  { sv4SignTime :: UTCTime,
-    sv4Scope :: ByteString,
-    sv4CanonicalRequest :: ByteString,
-    sv4HeadersToSign :: [(ByteString, ByteString)],
-    sv4Output :: [(ByteString, ByteString)],
-    sv4StringToSign :: ByteString,
-    sv4SigningKey :: ByteString
-  }
-  deriving stock (Show)
-
 data Service = ServiceS3 | ServiceSTS
   deriving stock (Eq, Show)
 
@@ -73,6 +72,7 @@ toByteString ServiceSTS = "sts"
 data SignParams = SignParams
   { spAccessKey :: Text,
     spSecretKey :: BA.ScrubbedBytes,
+    spSessionToken :: Maybe BA.ScrubbedBytes,
     spService :: Service,
     spTimeStamp :: UTCTime,
     spRegion :: Maybe Text,
@@ -81,23 +81,6 @@ data SignParams = SignParams
   }
   deriving stock (Show)
 
-debugPrintSignV4Data :: SignV4Data -> IO ()
-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 "Output: " >> print o
-  B8.putStr "StringToSign: " >> B8.putStrLn sts
-  B8.putStr "SigningKey: " >> printBytes sk
-  B8.putStrLn "END of SignV4Data ========="
-  where
-    printBytes b = do
-      mapM_ (\x -> B.putStr $ B.singleton x <> " ") $ B.unpack b
-      B8.putStrLn ""
-
 mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
 mkAuthHeader accessKey scope signedHeaderKeys sign =
   let authValue =
@@ -116,6 +99,9 @@ mkAuthHeader accessKey scope signedHeaderKeys sign =
 data IsStreaming = IsStreamingLength Int64 | NotStreaming
   deriving stock (Eq, Show)
 
+amzSecurityToken :: ByteString
+amzSecurityToken = "X-Amz-Security-Token"
+
 -- | Given SignParams and request details, including request method,
 -- request path, headers, query params and payload hash, generates an
 -- updated set of headers, including the x-amz-date header and the
@@ -144,6 +130,7 @@ signV4QueryParams !sp !req =
           ("X-Amz-Expires", maybe "" showBS expiry),
           ("X-Amz-SignedHeaders", signedHeaderKeys)
         ]
+          ++ maybeToList ((amzSecurityToken,) . BA.convert <$> spSessionToken sp)
       finalQP =
         parseQuery (NC.queryString req)
           ++ if isJust expiry
@@ -185,6 +172,7 @@ signV4 !sp !req =
                 | spService sp == ServiceS3
               ]
             )
+          ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)
 
       -- 1. compute canonical request
       reqHeaders = NC.requestHeaders req ++ extraHeaders
@@ -347,10 +335,11 @@ signV4PostPolicy !postPolicyJSON !sp =
   let stringToSign = Base64.encode postPolicyJSON
       signingKey = getSigningKey sp
       signature = computeSignature stringToSign signingKey
-   in Map.fromList
+   in Map.fromList $
         [ ("x-amz-signature", signature),
           ("policy", stringToSign)
         ]
+          ++ maybeToList ((decodeUtf8 amzSecurityToken,) . BA.convert <$> spSessionToken sp)
 
 chunkSizeConstant :: Int
 chunkSizeConstant = 64 * 1024
@@ -401,6 +390,7 @@ signV4Stream !payloadLength !sp !req =
           ("content-length", showBS signedContentLength),
           ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
         ]
+          ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)
       requestHeaders =
         addContentEncoding $
           foldr setHeader (NC.requestHeaders req) extraHeaders

src/Network/Minio/Utils.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -24,7 +24,6 @@ import qualified Data.ByteString.Lazy as LB
 import Data.CaseInsensitive (mk, original)
 import qualified Data.Conduit.Binary as CB
 import qualified Data.HashMap.Strict as H
-import qualified Data.List as List
 import qualified Data.Text as T
 import Data.Text.Read (decimal)
 import Data.Time
@@ -37,14 +36,12 @@ import Network.HTTP.Conduit (Response)
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
 import qualified Network.HTTP.Types.Header as Hdr
-import Network.Minio.Data
 import Network.Minio.Data.ByteString
 import Network.Minio.JsonParser (parseErrResponseJSON)
-import Network.Minio.XmlParser (parseErrResponse)
+import Network.Minio.XmlCommon (parseErrResponse)
 import qualified System.IO as IO
 import qualified UnliftIO as U
 import qualified UnliftIO.Async as A
-import qualified UnliftIO.MVar as UM
 
 allocateReadFile ::
   (MonadUnliftIO m, R.MonadResource m) =>
@@ -115,6 +112,16 @@ getMetadata :: [HT.Header] -> [(Text, Text)]
 getMetadata =
   map (\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y))
 
+-- | If the given header name has the @X-Amz-Meta-@ prefix, it is
+-- stripped and a Just is returned.
+userMetadataHeaderNameMaybe :: Text -> Maybe Text
+userMetadataHeaderNameMaybe k =
+  let prefix = T.toCaseFold "X-Amz-Meta-"
+      n = T.length prefix
+   in if T.toCaseFold (T.take n k) == prefix
+        then Just (T.drop n k)
+        else Nothing
+
 toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)
 toMaybeMetadataHeader (k, v) =
   (,v) <$> userMetadataHeaderNameMaybe k
@@ -128,6 +135,14 @@ getNonUserMetadataMap =
           . fst
       )
 
+addXAmzMetaPrefix :: Text -> Text
+addXAmzMetaPrefix s
+  | isJust (userMetadataHeaderNameMaybe s) = s
+  | otherwise = "X-Amz-Meta-" <> s
+
+mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]
+mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y))
+
 -- | This function collects all headers starting with `x-amz-meta-`
 -- and strips off this prefix, and returns a map.
 getUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text
@@ -135,6 +150,12 @@ getUserMetadataMap =
   H.fromList
     . mapMaybe toMaybeMetadataHeader
 
+getHostHeader :: (ByteString, Int) -> ByteString
+getHostHeader (host_, port_) =
+  if port_ == 80 || port_ == 443
+    then host_
+    else host_ <> ":" <> show port_
+
 getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime
 getLastModifiedHeader hs = do
   modTimebs <- decodeUtf8Lenient <$> lookupHeader Hdr.hLastModified hs
@@ -262,42 +283,3 @@ chunkBSConduit (s : ss) = do
       | B.length bs == s -> C.yield bs >> chunkBSConduit ss
       | B.length bs > 0 -> C.yield bs
       | otherwise -> return ()
-
--- | Select part sizes - the logic is that the minimum part-size will
--- be 64MiB.
-selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
-selectPartSizes size =
-  uncurry (List.zip3 [1 ..]) $
-    List.unzip $
-      loop 0 size
-  where
-    ceil :: Double -> Int64
-    ceil = ceiling
-    partSize =
-      max
-        minPartSize
-        ( ceil $
-            fromIntegral size
-              / fromIntegral maxMultipartParts
-        )
-    m = partSize
-    loop st sz
-      | st > sz = []
-      | st + m >= sz = [(st, sz - st)]
-      | otherwise = (st, m) : loop (st + m) sz
-
-lookupRegionCache :: Bucket -> Minio (Maybe Region)
-lookupRegionCache b = do
-  rMVar <- asks mcRegionMap
-  rMap <- UM.readMVar rMVar
-  return $ H.lookup b rMap
-
-addToRegionCache :: Bucket -> Region -> Minio ()
-addToRegionCache b region = do
-  rMVar <- asks mcRegionMap
-  UM.modifyMVar_ rMVar $ return . H.insert b region
-
-deleteFromRegionCache :: Bucket -> Minio ()
-deleteFromRegionCache b = do
-  rMVar <- asks mcRegionMap
-  UM.modifyMVar_ rMVar $ return . H.delete b

src/Network/Minio/XmlCommon.hs

@@ -0,0 +1,65 @@
+--
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+
+module Network.Minio.XmlCommon where
+
+import qualified Data.Text as T
+import Data.Text.Read (decimal)
+import Data.Time (UTCTime)
+import Data.Time.Format.ISO8601 (iso8601ParseM)
+import Lib.Prelude (throwIO)
+import Network.Minio.Errors
+import Text.XML (Name (Name), def, parseLBS)
+import Text.XML.Cursor (Axis, Cursor, content, element, fromDocument, laxElement, ($/), (&/))
+
+s3Name :: Text -> Text -> Name
+s3Name ns s = Name s (Just ns) Nothing
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 f (a, b, c, d) = f a b c d
+
+uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
+uncurry6 f (a, b, c, d, e, g) = f a b c d e g
+
+-- | Parse time strings from XML
+parseS3XMLTime :: MonadIO m => Text -> m UTCTime
+parseS3XMLTime t =
+  maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $
+    iso8601ParseM $
+      toString t
+
+parseDecimal :: (MonadIO m, Integral a) => Text -> m a
+parseDecimal numStr =
+  either (throwIO . MErrVXmlParse . show) return $
+    fst <$> decimal numStr
+
+parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a]
+parseDecimals numStr = forM numStr parseDecimal
+
+s3Elem :: Text -> Text -> Axis
+s3Elem ns = element . s3Name ns
+
+parseRoot :: (MonadIO m) => LByteString -> m Cursor
+parseRoot =
+  either (throwIO . MErrVXmlParse . show) (return . fromDocument)
+    . parseLBS def
+
+parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr
+parseErrResponse xmldata = do
+  r <- parseRoot xmldata
+  let code = T.concat $ r $/ laxElement "Code" &/ content
+      message = T.concat $ r $/ laxElement "Message" &/ content
+  return $ toServiceErr code message

src/Network/Minio/XmlGenerator.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -25,6 +25,7 @@ where
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as T
 import Network.Minio.Data
+import Network.Minio.XmlCommon
 import Text.XML
 
 -- | Create a bucketConfig request body XML

src/Network/Minio/XmlParser.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -27,54 +27,18 @@ module Network.Minio.XmlParser
     parseErrResponse,
     parseNotification,
     parseSelectProgress,
-    parseSTSAssumeRoleResult,
   )
 where
 
-import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.HashMap.Strict as H
 import Data.List (zip4, zip6)
 import qualified Data.Text as T
-import Data.Text.Read (decimal)
 import Data.Time
-import Data.Time.Format.ISO8601 (iso8601ParseM)
-import Lib.Prelude
 import Network.Minio.Data
-import Network.Minio.Errors
+import Network.Minio.XmlCommon
-import Text.XML
 import Text.XML.Cursor hiding (bool)
 
--- | Helper functions.
-uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
-uncurry4 f (a, b, c, d) = f a b c d
-
-uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
-uncurry6 f (a, b, c, d, e, g) = f a b c d e g
-
--- | Parse time strings from XML
-parseS3XMLTime :: MonadIO m => Text -> m UTCTime
-parseS3XMLTime t =
-  maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $
-    iso8601ParseM $
-      toString t
-
-parseDecimal :: (MonadIO m, Integral a) => Text -> m a
-parseDecimal numStr =
-  either (throwIO . MErrVXmlParse . show) return $
-    fst <$> decimal numStr
-
-parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a]
-parseDecimals numStr = forM numStr parseDecimal
-
-s3Elem :: Text -> Text -> Axis
-s3Elem ns = element . s3Name ns
-
-parseRoot :: (MonadIO m) => LByteString -> m Cursor
-parseRoot =
-  either (throwIO . MErrVXmlParse . show) (return . fromDocument)
-    . parseLBS def
-
 -- | Parse the response XML of a list buckets call.
 parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo]
 parseListBuckets xmldata = do
@@ -219,13 +183,6 @@ parseListPartsResponse xmldata = do
 
   return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos
 
-parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr
-parseErrResponse xmldata = do
-  r <- parseRoot xmldata
-  let code = T.concat $ r $/ laxElement "Code" &/ content
-      message = T.concat $ r $/ laxElement "Message" &/ content
-  return $ toServiceErr code message
-
 parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification
 parseNotification xmldata = do
   r <- parseRoot xmldata
@@ -271,102 +228,3 @@ parseSelectProgress xmldata = do
     <$> parseDecimal bScanned
     <*> parseDecimal bProcessed
     <*> parseDecimal bReturned
-
--- <AssumeRoleResponse xmlns="https://sts.amazonaws.com/doc/2011-06-15/">
---   <AssumeRoleResult>
---   <SourceIdentity>Alice</SourceIdentity>
---     <AssumedRoleUser>
---       <Arn>arn:aws:sts::123456789012:assumed-role/demo/TestAR</Arn>
---       <AssumedRoleId>ARO123EXAMPLE123:TestAR</AssumedRoleId>
---     </AssumedRoleUser>
---     <Credentials>
---       <AccessKeyId>ASIAIOSFODNN7EXAMPLE</AccessKeyId>
---       <SecretAccessKey>wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY</SecretAccessKey>
---       <SessionToken>
---        AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW
---        LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd
---        QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU
---        9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz
---        +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA==
---       </SessionToken>
---       <Expiration>2019-11-09T13:34:41Z</Expiration>
---     </Credentials>
---     <PackedPolicySize>6</PackedPolicySize>
---   </AssumeRoleResult>
---   <ResponseMetadata>
---     <RequestId>c6104cbe-af31-11e0-8154-cbc7ccf896c7</RequestId>
---   </ResponseMetadata>
--- </AssumeRoleResponse>
-
-parseSTSAssumeRoleResult :: MonadIO m => ByteString -> Text -> m AssumeRoleResult
-parseSTSAssumeRoleResult xmldata namespace = do
-  r <- parseRoot $ LB.fromStrict xmldata
-  let s3Elem' = s3Elem namespace
-      sourceIdentity =
-        T.concat $
-          r
-            $/ s3Elem' "AssumeRoleResult"
-            &/ s3Elem' "SourceIdentity"
-            &/ content
-      roleArn =
-        T.concat $
-          r
-            $/ s3Elem' "AssumeRoleResult"
-            &/ s3Elem' "AssumedRoleUser"
-            &/ s3Elem' "Arn"
-            &/ content
-      roleId =
-        T.concat $
-          r
-            $/ s3Elem' "AssumeRoleResult"
-            &/ s3Elem' "AssumedRoleUser"
-            &/ s3Elem' "AssumedRoleId"
-            &/ content
-
-      convSB :: Text -> BA.ScrubbedBytes
-      convSB = BA.convert . (encodeUtf8 :: Text -> ByteString)
-
-      credsInfo = do
-        cr <-
-          maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $
-            listToMaybe $
-              r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials"
-        let cur = fromNode $ node cr
-        return
-          ( CredentialValue
-              { cvAccessKey =
-                  coerce $
-                    T.concat $
-                      cur $/ s3Elem' "AccessKeyId" &/ content,
-                cvSecretKey =
-                  coerce $
-                    convSB $
-                      T.concat $
-                        cur
-                          $/ s3Elem' "SecretAccessKey"
-                          &/ content,
-                cvSessionToken =
-                  Just $
-                    coerce $
-                      convSB $
-                        T.concat $
-                          cur
-                            $/ s3Elem' "SessionToken"
-                            &/ content
-              },
-            T.concat $ cur $/ s3Elem' "Expiration" &/ content
-          )
-  creds <- either throwIO pure credsInfo
-  expiry <- parseS3XMLTime $ snd creds
-  let roleCredentials =
-        AssumeRoleCredentials
-          { arcCredentials = fst creds,
-            arcExpiration = expiry
-          }
-  return
-    AssumeRoleResult
-      { arrSourceIdentity = sourceIdentity,
-        arrAssumedRoleArn = roleArn,
-        arrAssumedRoleId = roleId,
-        arrRoleCredentials = roleCredentials
-      }

test/LiveServer.hs

@@ -1,7 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --
--- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -32,6 +30,7 @@ import qualified Network.HTTP.Client.MultipartFormData as Form
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
 import Network.Minio
+import Network.Minio.Credentials (Creds (CredsStatic))
 import Network.Minio.Data
 import Network.Minio.Data.Crypto
 import Network.Minio.S3API
@@ -77,15 +76,35 @@ mkRandFile size = do
 funTestBucketPrefix :: Text
 funTestBucketPrefix = "miniohstest-"
 
-loadTestServer :: IO ConnectInfo
+loadTestServerConnInfo :: IO ConnectInfo
-loadTestServer = do
+loadTestServerConnInfo = do
   val <- Env.lookupEnv "MINIO_LOCAL"
   isSecure <- Env.lookupEnv "MINIO_SECURE"
   return $ case (val, isSecure) of
-    (Just _, Just _) -> setCreds (Credentials "minio" "minio123") "https://localhost:9000"
+    (Just _, Just _) -> setCreds (CredentialValue "minio" "minio123" mempty) "https://localhost:9000"
-    (Just _, Nothing) -> setCreds (Credentials "minio" "minio123") "http://localhost:9000"
+    (Just _, Nothing) -> setCreds (CredentialValue "minio" "minio123" mempty) "http://localhost:9000"
     (Nothing, _) -> minioPlayCI
 
+loadTestServerConnInfoSTS :: IO ConnectInfo
+loadTestServerConnInfoSTS = do
+  val <- Env.lookupEnv "MINIO_LOCAL"
+  isSecure <- Env.lookupEnv "MINIO_SECURE"
+  let cv = CredentialValue "minio" "minio123" mempty
+      assumeRole =
+        STSAssumeRole
+          { sarCredentials = cv,
+            sarOptions = defaultSTSAssumeRoleOptions
+          }
+  case (val, isSecure) of
+    (Just _, Just _) -> setSTSCredential assumeRole "https://localhost:9000"
+    (Just _, Nothing) -> setSTSCredential assumeRole "http://localhost:9000"
+    (Nothing, _) -> do
+      cv' <- case connectCreds minioPlayCI of
+        CredsStatic c -> return c
+        _ -> error "unexpected play creds"
+      let assumeRole' = assumeRole {sarCredentials = cv'}
+      setSTSCredential assumeRole' minioPlayCI
+
 funTestWithBucket ::
   TestName ->
   (([Char] -> Minio ()) -> Bucket -> Minio ()) ->
@@ -95,7 +114,7 @@ funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
   bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
   let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]
       liftStep = liftIO . step
-  connInfo <- loadTestServer
+  connInfo <- loadTestServerConnInfo
   ret <- runMinio connInfo $ do
     liftStep $ "Creating bucket for test - " ++ t
     foundBucket <- bucketExists b
@@ -105,6 +124,17 @@ funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
     deleteBucket b
   isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
 
+  connInfoSTS <- loadTestServerConnInfoSTS
+  let t' = t ++ " (with AssumeRole Credentials)"
+  ret' <- runMinio connInfoSTS $ do
+    liftStep $ "Creating bucket for test - " ++ t'
+    foundBucket <- bucketExists b
+    liftIO $ foundBucket @?= False
+    makeBucket b Nothing
+    minioTest liftStep b
+    deleteBucket b
+  isRight ret' @? ("Functional test " ++ t' ++ " failed => " ++ show ret')
+
 liveServerUnitTests :: TestTree
 liveServerUnitTests =
   testGroup
@@ -125,7 +155,8 @@ liveServerUnitTests =
       presignedUrlFunTest,
       presignedPostPolicyFunTest,
       bucketPolicyFunTest,
-      getNPutSSECTest
+      getNPutSSECTest,
+      assumeRoleRequestTest
     ]
 
 basicTests :: TestTree
@@ -1187,3 +1218,30 @@ getNPutSSECTest =
         step "Cleanup"
         deleteObject bucket obj
       else step "Skipping encryption test as server is not using TLS"
+
+assumeRoleRequestTest :: TestTree
+assumeRoleRequestTest = testCaseSteps "Assume Role STS API" $ \step -> do
+  step "Load credentials"
+  val <- Env.lookupEnv "MINIO_LOCAL"
+  isSecure <- Env.lookupEnv "MINIO_SECURE"
+  let localMinioCred = Just $ CredentialValue "minio" "minio123" mempty
+      playCreds =
+        case connectCreds minioPlayCI of
+          CredsStatic c -> Just c
+          _ -> Nothing
+      (cvMay, loc) =
+        case (val, isSecure) of
+          (Just _, Just _) -> (localMinioCred, "https://localhost:9000")
+          (Just _, Nothing) -> (localMinioCred, "http://localhost:9000")
+          (Nothing, _) -> (playCreds, "https://play.min.io:9000")
+  cv <- maybe (assertFailure "bad creds") return cvMay
+  let assumeRole =
+        STSAssumeRole cv $
+          defaultSTSAssumeRoleOptions
+            { saroLocation = Just "us-east-1",
+              saroEndpoint = Just loc
+            }
+  step "AssumeRole request"
+  res <- requestSTSCredential assumeRole
+  let v = credentialValueText $ fst res
+  print (v, snd res)

test/Spec.hs

@@ -1,5 +1,5 @@
 --
--- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -20,7 +20,6 @@ import Lib.Prelude
 import Network.Minio.API.Test
 import Network.Minio.CopyObject
 import Network.Minio.Data
-import Network.Minio.PutObject
 import Network.Minio.Utils.Test
 import Network.Minio.XmlGenerator.Test
 import Network.Minio.XmlParser.Test