Add Credentials module to use Assume Role API (#184)

This exports a new module for retrieving STS based credentials, however
they are not yet convenient to use in the library - the session token
needs to be included as a custom header and may not be possible with all
APIs.

.github/workflows/ci.yml

@@ -25,7 +25,7 @@ jobs:
     runs-on: ubuntu-latest
     steps:
       - uses: actions/checkout@v3
-      - uses: mrkkrp/ormolu-action@v6
+      - uses: mrkkrp/ormolu-action@v8
 
   hlint:
     runs-on: ubuntu-latest

examples/AssumeRole.hs

@@ -0,0 +1,33 @@
+--
+-- MinIO Haskell SDK, (C) 2022 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 OverloadedStrings #-}
+
+import Network.Minio.Credentials
+import Prelude
+
+main :: IO ()
+main = do
+  res <-
+    retrieveCredentials
+      $ STSAssumeRole
+        "https://play.min.io"
+        ( CredentialValue
+            "Q3AM3UQ867SPQQA43P2F"
+            "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"
+            Nothing
+        )
+      $ defaultSTSAssumeRoleOptions {saroLocation = Just "us-east-1"}
+  print res

minio-hs.cabal

@@ -128,6 +128,7 @@ common base-settings
                      , retry
                      , text >= 1.2
                      , time >= 1.9
+                     , time-units ^>= 1.0.0
                      , transformers >= 0.5
                      , unliftio >= 0.2 && < 0.3
                      , unliftio-core >= 0.2 && < 0.3
@@ -140,6 +141,7 @@ 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
@@ -339,3 +341,8 @@ executable SetConfig
   import:              examples-settings
   scope:               private
   main-is:             SetConfig.hs
+
+executable AssumeRole
+  import:              examples-settings
+  scope:               private
+  main-is:             AssumeRole.hs

src/Network/Minio/API.hs

@@ -34,6 +34,7 @@ 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
@@ -44,6 +45,7 @@ import Lib.Prelude
 import qualified Network.HTTP.Client as NClient
 import Network.HTTP.Conduit (Response)
 import qualified Network.HTTP.Conduit as NC
+import Network.HTTP.Types (simpleQueryToQuery)
 import qualified Network.HTTP.Types as HT
 import Network.HTTP.Types.Header (hHost)
 import Network.Minio.APICommon
@@ -176,7 +178,8 @@ buildRequest ri = do
   let sp =
         SignParams
           (connectAccessKey ci')
-          (connectSecretKey ci')
+          (BA.convert (encodeUtf8 $ connectSecretKey ci' :: ByteString))
+          ServiceS3
           timeStamp
           (riRegion ri')
           (riPresignExpirySecs ri')
@@ -198,8 +201,8 @@ buildRequest ri = do
       | isJust (riPresignExpirySecs ri') ->
           -- case 0 from above.
           do
-            let signPairs = signV4 sp baseRequest
+            let signPairs = signV4QueryParams sp baseRequest
-                qpToAdd = (fmap . fmap) Just signPairs
+                qpToAdd = simpleQueryToQuery signPairs
                 existingQueryParams = HT.parseQuery (NC.queryString baseRequest)
                 updatedQueryParams = existingQueryParams ++ qpToAdd
             return $ NClient.setQueryString updatedQueryParams baseRequest
@@ -229,8 +232,7 @@ buildRequest ri = do
             return $
               baseRequest
                 { NC.requestHeaders =
-                    NC.requestHeaders baseRequest
+                    NC.requestHeaders baseRequest ++ signHeaders,
-                      ++ mkHeaderFromPairs signHeaders,
                   NC.requestBody = getRequestBody (riPayload ri')
                 }
 

src/Network/Minio/AdminAPI.hs

@@ -70,6 +70,7 @@ 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
@@ -95,9 +96,12 @@ data DriveInfo = DriveInfo
 instance FromJSON DriveInfo where
   parseJSON = withObject "DriveInfo" $ \v ->
     DriveInfo
-      <$> v .: "uuid"
+      <$> v
-      <*> v .: "endpoint"
+        .: "uuid"
-      <*> v .: "state"
+      <*> v
+        .: "endpoint"
+      <*> v
+        .: "state"
 
 data StorageClass = StorageClass
   { scParity :: Int,
@@ -120,12 +124,16 @@ instance FromJSON ErasureInfo where
     offlineDisks <- v .: "OfflineDisks"
     stdClass <-
       StorageClass
-        <$> v .: "StandardSCData"
+        <$> v
-        <*> v .: "StandardSCParity"
+          .: "StandardSCData"
+        <*> v
+          .: "StandardSCParity"
     rrClass <-
       StorageClass
-        <$> v .: "RRSCData"
+        <$> v
-        <*> v .: "RRSCParity"
+          .: "RRSCData"
+        <*> v
+          .: "RRSCParity"
     sets <- v .: "Sets"
     return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets
 
@@ -151,8 +159,10 @@ data ConnStats = ConnStats
 instance FromJSON ConnStats where
   parseJSON = withObject "ConnStats" $ \v ->
     ConnStats
-      <$> v .: "transferred"
+      <$> v
-      <*> v .: "received"
+        .: "transferred"
+      <*> v
+        .: "received"
 
 data ServerProps = ServerProps
   { spUptime :: NominalDiffTime,
@@ -182,8 +192,10 @@ data StorageInfo = StorageInfo
 instance FromJSON StorageInfo where
   parseJSON = withObject "StorageInfo" $ \v ->
     StorageInfo
-      <$> v .: "Used"
+      <$> v
-      <*> v .: "Backend"
+        .: "Used"
+      <*> v
+        .: "Backend"
 
 data CountNAvgTime = CountNAvgTime
   { caCount :: Int64,
@@ -194,8 +206,10 @@ data CountNAvgTime = CountNAvgTime
 instance FromJSON CountNAvgTime where
   parseJSON = withObject "CountNAvgTime" $ \v ->
     CountNAvgTime
-      <$> v .: "count"
+      <$> v
-      <*> v .: "avgDuration"
+        .: "count"
+      <*> v
+        .: "avgDuration"
 
 data HttpStats = HttpStats
   { hsTotalHeads :: CountNAvgTime,
@@ -214,16 +228,26 @@ data HttpStats = HttpStats
 instance FromJSON HttpStats where
   parseJSON = withObject "HttpStats" $ \v ->
     HttpStats
-      <$> v .: "totalHEADs"
+      <$> v
-      <*> v .: "successHEADs"
+        .: "totalHEADs"
-      <*> v .: "totalGETs"
+      <*> v
-      <*> v .: "successGETs"
+        .: "successHEADs"
-      <*> v .: "totalPUTs"
+      <*> v
-      <*> v .: "successPUTs"
+        .: "totalGETs"
-      <*> v .: "totalPOSTs"
+      <*> v
-      <*> v .: "successPOSTs"
+        .: "successGETs"
-      <*> v .: "totalDELETEs"
+      <*> v
-      <*> v .: "successDELETEs"
+        .: "totalPUTs"
+      <*> v
+        .: "successPUTs"
+      <*> v
+        .: "totalPOSTs"
+      <*> v
+        .: "successPOSTs"
+      <*> v
+        .: "totalDELETEs"
+      <*> v
+        .: "successDELETEs"
 
 data SIData = SIData
   { sdStorage :: StorageInfo,
@@ -236,10 +260,14 @@ data SIData = SIData
 instance FromJSON SIData where
   parseJSON = withObject "SIData" $ \v ->
     SIData
-      <$> v .: "storage"
+      <$> v
-      <*> v .: "network"
+        .: "storage"
-      <*> v .: "http"
+      <*> v
-      <*> v .: "server"
+        .: "network"
+      <*> v
+        .: "http"
+      <*> v
+        .: "server"
 
 data ServerInfo = ServerInfo
   { siError :: Text,
@@ -251,9 +279,12 @@ data ServerInfo = ServerInfo
 instance FromJSON ServerInfo where
   parseJSON = withObject "ServerInfo" $ \v ->
     ServerInfo
-      <$> v .: "error"
+      <$> v
-      <*> v .: "addr"
+        .: "error"
-      <*> v .: "data"
+      <*> v
+        .: "addr"
+      <*> v
+        .: "data"
 
 data ServerVersion = ServerVersion
   { svVersion :: Text,
@@ -264,8 +295,10 @@ data ServerVersion = ServerVersion
 instance FromJSON ServerVersion where
   parseJSON = withObject "ServerVersion" $ \v ->
     ServerVersion
-      <$> v .: "version"
+      <$> v
-      <*> v .: "commitID"
+        .: "version"
+      <*> v
+        .: "commitID"
 
 data ServiceStatus = ServiceStatus
   { ssVersion :: ServerVersion,
@@ -306,9 +339,12 @@ data HealStartResp = HealStartResp
 instance FromJSON HealStartResp where
   parseJSON = withObject "HealStartResp" $ \v ->
     HealStartResp
-      <$> v .: "clientToken"
+      <$> v
-      <*> v .: "clientAddress"
+        .: "clientToken"
-      <*> v .: "startTime"
+      <*> v
+        .: "clientAddress"
+      <*> v
+        .: "startTime"
 
 data HealOpts = HealOpts
   { hoRecursive :: Bool,
@@ -325,8 +361,10 @@ instance ToJSON HealOpts where
 instance FromJSON HealOpts where
   parseJSON = withObject "HealOpts" $ \v ->
     HealOpts
-      <$> v .: "recursive"
+      <$> v
-      <*> v .: "dryRun"
+        .: "recursive"
+      <*> v
+        .: "dryRun"
 
 data HealItemType
   = HealItemMetadata
@@ -353,9 +391,12 @@ data NodeSummary = NodeSummary
 instance FromJSON NodeSummary where
   parseJSON = withObject "NodeSummary" $ \v ->
     NodeSummary
-      <$> v .: "name"
+      <$> v
-      <*> v .: "errSet"
+        .: "name"
-      <*> v .: "errMsg"
+      <*> v
+        .: "errSet"
+      <*> v
+        .: "errMsg"
 
 data SetConfigResult = SetConfigResult
   { scrStatus :: Bool,
@@ -366,8 +407,10 @@ data SetConfigResult = SetConfigResult
 instance FromJSON SetConfigResult where
   parseJSON = withObject "SetConfigResult" $ \v ->
     SetConfigResult
-      <$> v .: "status"
+      <$> v
-      <*> v .: "nodeResults"
+        .: "status"
+      <*> v
+        .: "nodeResults"
 
 data HealResultItem = HealResultItem
   { hriResultIdx :: Int,
@@ -388,16 +431,26 @@ data HealResultItem = HealResultItem
 instance FromJSON HealResultItem where
   parseJSON = withObject "HealResultItem" $ \v ->
     HealResultItem
-      <$> v .: "resultId"
+      <$> v
-      <*> v .: "type"
+        .: "resultId"
-      <*> v .: "bucket"
+      <*> v
-      <*> v .: "object"
+        .: "type"
-      <*> v .: "detail"
+      <*> v
-      <*> v .:? "parityBlocks"
+        .: "bucket"
-      <*> v .:? "dataBlocks"
+      <*> v
-      <*> v .: "diskCount"
+        .: "object"
-      <*> v .: "setCount"
+      <*> v
-      <*> v .: "objectSize"
+        .: "detail"
+      <*> v
+        .:? "parityBlocks"
+      <*> v
+        .:? "dataBlocks"
+      <*> v
+        .: "diskCount"
+      <*> v
+        .: "setCount"
+      <*> v
+        .: "objectSize"
       <*> ( do
               before <- v .: "before"
               before .: "drives"
@@ -420,12 +473,18 @@ data HealStatus = HealStatus
 instance FromJSON HealStatus where
   parseJSON = withObject "HealStatus" $ \v ->
     HealStatus
-      <$> v .: "Summary"
+      <$> v
-      <*> v .: "StartTime"
+        .: "Summary"
-      <*> v .: "Settings"
+      <*> v
-      <*> v .: "NumDisks"
+        .: "StartTime"
-      <*> v .:? "Detail"
+      <*> v
-      <*> v .: "Items"
+        .: "Settings"
+      <*> v
+        .: "NumDisks"
+      <*> v
+        .:? "Detail"
+      <*> v
+        .: "Items"
 
 healPath :: Maybe Bucket -> Maybe Text -> ByteString
 healPath bucket prefix = do
@@ -620,7 +679,8 @@ buildAdminRequest areq = do
       sp =
         SignParams
           (connectAccessKey ci)
-          (connectSecretKey ci)
+          (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString))
+          ServiceS3
           timeStamp
           Nothing
           Nothing
@@ -630,7 +690,7 @@ buildAdminRequest areq = do
   -- Update signReq with Authorization header containing v4 signature
   return
     signReq
-      { NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders
+      { NC.requestHeaders = ariHeaders newAreq ++ signHeaders
       }
   where
     toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request

src/Network/Minio/Credentials.hs

@@ -0,0 +1,144 @@
+--
+-- MinIO Haskell SDK, (C) 2017-2022 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
+  ( CredentialValue (..),
+    CredentialProvider (..),
+    AccessKey,
+    SecretKey,
+    SessionToken,
+    defaultSTSAssumeRoleOptions,
+    STSAssumeRole (..),
+    STSAssumeRoleOptions (..),
+  )
+where
+
+import qualified Data.Time as Time
+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.HTTP.Types (hContentType, methodPost, renderSimpleQuery)
+import Network.HTTP.Types.Header (hHost)
+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
+  retrieveCredentials :: p -> IO CredentialValue
+
+stsVersion :: ByteString
+stsVersion = "2011-06-15"
+
+defaultDurationSeconds :: Second
+defaultDurationSeconds = 3600
+
+data STSAssumeRole = STSAssumeRole
+  { sarEndpoint :: Text,
+    sarCredentials :: CredentialValue,
+    sarOptions :: STSAssumeRoleOptions
+  }
+
+data STSAssumeRoleOptions = STSAssumeRoleOptions
+  { -- | 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,
+    -- | Optional HTTP connection manager
+    saroHTTPManager :: Maybe NC.Manager
+  }
+
+-- | Default STS Assume Role options
+defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions
+defaultSTSAssumeRoleOptions =
+  STSAssumeRoleOptions
+    { saroDurationSeconds = Just defaultDurationSeconds,
+      saroPolicyJSON = Nothing,
+      saroLocation = Nothing,
+      saroRoleARN = Nothing,
+      saroRoleSessionName = Nothing,
+      saroHTTPManager = Nothing
+    }
+
+instance CredentialProvider STSAssumeRole where
+  retrieveCredentials sar = 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) =
+          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.
+    timeStamp <- liftIO Time.getCurrentTime
+    let sp =
+          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/Data.hs

@@ -232,16 +232,14 @@ isConnectInfoSecure = connectIsSecure
 disableTLSCertValidation :: ConnectInfo -> ConnectInfo
 disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}
 
-getHostAddr :: ConnectInfo -> ByteString
+getHostHeader :: (ByteString, Int) -> ByteString
-getHostAddr ci =
+getHostHeader (host, port) =
   if port == 80 || port == 443
-    then encodeUtf8 host
+    then host
-    else
+    else host <> ":" <> show port
-      encodeUtf8 $
+
-        T.concat [host, ":", show port]
+getHostAddr :: ConnectInfo -> ByteString
-  where
+getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort ci)
-    port = connectPort ci
-    host = connectHost ci
 
 -- | Default Google Compute Storage ConnectInfo. Works only for
 -- "Simple Migration" use-case with interoperability mode enabled on
@@ -1002,6 +1000,47 @@ 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

src/Network/Minio/PresignedOperations.hs

@@ -39,6 +39,7 @@ 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
@@ -300,7 +301,7 @@ presignedPostPolicy p = do
   ci <- asks mcConnInfo
   signTime <- liftIO Time.getCurrentTime
 
-  let extraConditions =
+  let extraConditions signParams =
         [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),
           PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",
           PPCEquals
@@ -308,23 +309,24 @@ presignedPostPolicy p = do
             ( T.intercalate
                 "/"
                 [ connectAccessKey ci,
-                  decodeUtf8 $ mkScope signTime region
+                  decodeUtf8 $ credentialScope signParams
                 ]
             )
         ]
-      ppWithCreds =
+      ppWithCreds signParams =
         p
-          { conditions = conditions p ++ extraConditions
+          { conditions = conditions p ++ extraConditions signParams
           }
       sp =
         SignParams
           (connectAccessKey ci)
-          (connectSecretKey ci)
+          (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString))
+          ServiceS3
           signTime
           (Just $ connectRegion ci)
           Nothing
           Nothing
-      signData = signV4PostPolicy (showPostPolicy ppWithCreds) sp
+      signData = signV4PostPolicy (showPostPolicy $ ppWithCreds sp) sp
       -- compute form-data
       mkPair (PPCStartsWith k v) = Just (k, v)
       mkPair (PPCEquals k v) = Just (k, v)
@@ -334,12 +336,11 @@ presignedPostPolicy p = do
           H.fromList $
             mapMaybe
               mkPair
-              (conditions ppWithCreds)
+              (conditions $ ppWithCreds sp)
       formData = formFromPolicy `H.union` signData
       -- compute POST upload URL
       bucket = H.lookupDefault "" "bucket" formData
       scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
-      region = connectRegion ci
       url =
         toStrictBS $
           toLazyByteString $

src/Network/Minio/Sign/V4.hs

@@ -18,19 +18,22 @@
 module Network.Minio.Sign.V4 where
 
 import qualified Conduit as C
+import qualified Data.ByteArray as BA
 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
+import Data.List (partition)
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Time as Time
 import Lib.Prelude
 import qualified Network.HTTP.Conduit as NC
-import Network.HTTP.Types (Header, parseQuery)
+import Network.HTTP.Types (Header, SimpleQuery, hContentEncoding, parseQuery)
 import qualified Network.HTTP.Types as H
+import Network.HTTP.Types.Header (RequestHeaders)
 import Network.Minio.Data.ByteString
 import Network.Minio.Data.Crypto
 import Network.Minio.Data.Time
@@ -60,9 +63,17 @@ data SignV4Data = SignV4Data
   }
   deriving stock (Show)
 
+data Service = ServiceS3 | ServiceSTS
+  deriving stock (Eq, Show)
+
+toByteString :: Service -> ByteString
+toByteString ServiceS3 = "s3"
+toByteString ServiceSTS = "sts"
+
 data SignParams = SignParams
   { spAccessKey :: Text,
-    spSecretKey :: Text,
+    spSecretKey :: BA.ScrubbedBytes,
+    spService :: Service,
     spTimeStamp :: UTCTime,
     spRegion :: Maybe Text,
     spExpirySecs :: Maybe UrlExpiry,
@@ -102,6 +113,9 @@ mkAuthHeader accessKey scope signedHeaderKeys sign =
           ]
    in (H.hAuthorization, authValue)
 
+data IsStreaming = IsStreamingLength Int64 | NotStreaming
+  deriving stock (Eq, Show)
+
 -- | 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
@@ -114,33 +128,19 @@ mkAuthHeader accessKey scope signedHeaderKeys sign =
 -- is being created. The expiry is interpreted as an integer number of
 -- seconds. The output will be the list of query-parameters to add to
 -- the request.
-signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]
+signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery
-signV4 !sp !req =
+signV4QueryParams !sp !req =
-  let region = fromMaybe "" $ spRegion sp
+  let scope = credentialScope sp
-      ts = spTimeStamp sp
-      scope = mkScope ts region
-      accessKey = encodeUtf8 $ spAccessKey sp
-      secretKey = encodeUtf8 $ spSecretKey sp
       expiry = spExpirySecs sp
-      sha256Hdr =
+
-        ( "x-amz-content-sha256",
+      headersToSign = getHeadersToSign $ NC.requestHeaders req
-          fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
-        )
-      -- headers to be added to the request
-      datePair = ("X-Amz-Date", awsTimeFormatBS ts)
-      computedHeaders =
-        NC.requestHeaders req
-          ++ if isJust expiry
-            then []
-            else map (first mk) [datePair, sha256Hdr]
-      headersToSign = getHeadersToSign computedHeaders
       signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
       -- query-parameters to be added before signing for presigned URLs
       -- (i.e. when `isJust expiry`)
       authQP =
         [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"),
-          ("X-Amz-Credential", B.concat [accessKey, "/", scope]),
+          ("X-Amz-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]),
-          datePair,
+          ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),
           ("X-Amz-Expires", maybe "" showBS expiry),
           ("X-Amz-SignedHeaders", signedHeaderKeys)
         ]
@@ -156,40 +156,129 @@ signV4 !sp !req =
           sp
           (NC.setQueryString finalQP req)
           headersToSign
+
       -- 2. compute string to sign
-      stringToSign = mkStringToSign ts scope canonicalRequest
+      stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest
       -- 3.1 compute signing key
-      signingKey = mkSigningKey ts region secretKey
+      signingKey = getSigningKey sp
+      -- 3.2 compute signature
+      signature = computeSignature stringToSign signingKey
+   in ("X-Amz-Signature", signature) : authQP
+
+-- | 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 Authorization header, which
+-- includes the signature.
+--
+-- The output is the list of headers to be added to authenticate the request.
+signV4 :: SignParams -> NC.Request -> [Header]
+signV4 !sp !req =
+  let scope = credentialScope sp
+
+      -- extra headers to be added for signing purposes.
+      extraHeaders =
+        ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp)
+          : ( -- payload hash is only used for S3 (not STS)
+              [ ( "x-amz-content-sha256",
+                  fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
+                )
+                | spService sp == ServiceS3
+              ]
+            )
+
+      -- 1. compute canonical request
+      reqHeaders = NC.requestHeaders req ++ extraHeaders
+      (canonicalRequest, signedHeaderKeys) =
+        getCanonicalRequestAndSignedHeaders
+          NotStreaming
+          sp
+          req
+          reqHeaders
+
+      -- 2. compute string to sign
+      stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest
+      -- 3.1 compute signing key
+      signingKey = getSigningKey sp
       -- 3.2 compute signature
       signature = computeSignature stringToSign signingKey
       -- 4. compute auth header
       authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature
-      -- finally compute output pairs
+   in authHeader : extraHeaders
-      output =
-        if isJust expiry
-          then ("X-Amz-Signature", signature) : authQP
-          else
-            [ first CI.foldedCase authHeader,
-              datePair,
-              sha256Hdr
-            ]
-   in output
 
-mkScope :: UTCTime -> Text -> ByteString
+credentialScope :: SignParams -> ByteString
-mkScope ts region =
+credentialScope sp =
-  B.intercalate
+  let region = fromMaybe "" $ spRegion sp
-    "/"
+   in B.intercalate
-    [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,
+        "/"
-      encodeUtf8 region,
+        [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp,
-      "s3",
+          encodeUtf8 region,
-      "aws4_request"
+          toByteString $ spService sp,
-    ]
+          "aws4_request"
+        ]
 
+-- Folds header name, trims whitespace in header values, skips ignored headers
+-- and sorts headers.
 getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
 getHeadersToSign !h =
   filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $
     map (bimap CI.foldedCase stripBS) h
 
+-- | Given the list of headers in the request, computes the canonical headers
+-- and the signed headers strings.
+getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)
+getCanonicalHeaders h =
+  let -- Folds header name, trims spaces in header values, skips ignored
+      -- headers and sorts headers by name (we must not re-order multi-valued
+      -- headers).
+      headersToSign =
+        NE.toList $
+          NE.sortBy (\a b -> compare (fst a) (fst b)) $
+            NE.fromList $
+              NE.filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $
+                NE.map (bimap CI.foldedCase stripBS) h
+
+      canonicalHeaders = mconcat $ map (\(a, b) -> a <> ":" <> b <> "\n") headersToSign
+      signedHeaderKeys = B.intercalate ";" $ map fst headersToSign
+   in (canonicalHeaders, signedHeaderKeys)
+
+getCanonicalRequestAndSignedHeaders ::
+  IsStreaming ->
+  SignParams ->
+  NC.Request ->
+  [Header] ->
+  (ByteString, ByteString)
+getCanonicalRequestAndSignedHeaders isStreaming sp req requestHeaders =
+  let httpMethod = NC.method req
+
+      canonicalUri = uriEncode False $ NC.path req
+
+      canonicalQueryString =
+        B.intercalate "&" $
+          map (\(x, y) -> B.concat [x, "=", y]) $
+            sort $
+              map
+                ( bimap (uriEncode True) (maybe "" (uriEncode True))
+                )
+                (parseQuery $ NC.queryString req)
+
+      (canonicalHeaders, signedHeaderKeys) = getCanonicalHeaders $ NE.fromList requestHeaders
+      payloadHashStr =
+        case isStreaming of
+          IsStreamingLength _ -> "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
+          NotStreaming -> fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
+
+      canonicalRequest =
+        B.intercalate
+          "\n"
+          [ httpMethod,
+            canonicalUri,
+            canonicalQueryString,
+            canonicalHeaders,
+            signedHeaderKeys,
+            payloadHashStr
+          ]
+   in (canonicalRequest, signedHeaderKeys)
+
 mkCanonicalRequest ::
   Bool ->
   SignParams ->
@@ -197,10 +286,12 @@ mkCanonicalRequest ::
   [(ByteString, ByteString)] ->
   ByteString
 mkCanonicalRequest !isStreaming !sp !req !headersForSign =
-  let canonicalQueryString =
+  let httpMethod = NC.method req
+      canonicalUri = uriEncode False $ NC.path req
+      canonicalQueryString =
         B.intercalate "&" $
           map (\(x, y) -> B.concat [x, "=", y]) $
-            sort $
+            sortBy (\a b -> compare (fst a) (fst b)) $
               map
                 ( bimap (uriEncode True) (maybe "" (uriEncode True))
                 )
@@ -216,8 +307,8 @@ mkCanonicalRequest !isStreaming !sp !req !headersForSign =
           else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
    in B.intercalate
         "\n"
-        [ NC.method req,
+        [ httpMethod,
-          uriEncode False $ NC.path req,
+          canonicalUri,
           canonicalQueryString,
           canonicalHeaders,
           signedHeaders,
@@ -234,13 +325,13 @@ mkStringToSign ts !scope !canonicalRequest =
       hashSHA256 canonicalRequest
     ]
 
-mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString
+getSigningKey :: SignParams -> ByteString
-mkSigningKey ts region !secretKey =
+getSigningKey sp =
   hmacSHA256RawBS "aws4_request"
-    . hmacSHA256RawBS "s3"
+    . hmacSHA256RawBS (toByteString $ spService sp)
-    . hmacSHA256RawBS (encodeUtf8 region)
+    . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp)
-    . hmacSHA256RawBS (awsDateFormatBS ts)
+    . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp)
-    $ B.concat ["AWS4", secretKey]
+    $ B.concat ["AWS4", BA.convert $ spSecretKey sp]
 
 computeSignature :: ByteString -> ByteString -> ByteString
 computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key
@@ -254,8 +345,7 @@ signV4PostPolicy ::
   Map.HashMap Text ByteString
 signV4PostPolicy !postPolicyJSON !sp =
   let stringToSign = Base64.encode postPolicyJSON
-      region = fromMaybe "" $ spRegion sp
+      signingKey = getSigningKey sp
-      signingKey = mkSigningKey (spTimeStamp sp) region $ encodeUtf8 $ spSecretKey sp
       signature = computeSignature stringToSign signingKey
    in Map.fromList
         [ ("x-amz-signature", signature),
@@ -284,60 +374,59 @@ signedStreamLength dataLen =
       finalChunkSize = 1 + 17 + 64 + 2 + 2
    in numChunks * fullChunkSize + lastChunkSize + finalChunkSize
 
+-- For streaming S3, we need to update the content-encoding header.
+addContentEncoding :: [Header] -> [Header]
+addContentEncoding hs =
+  -- assume there is at most one content-encoding header.
+  let (ceHdrs, others) = partition ((== hContentEncoding) . fst) hs
+   in maybe
+        (hContentEncoding, "aws-chunked")
+        (\(k, v) -> (k, v <> ",aws-chunked"))
+        (listToMaybe ceHdrs)
+        : others
+
 signV4Stream ::
   Int64 ->
   SignParams ->
   NC.Request ->
   (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
--- -> ([Header], C.ConduitT () ByteString (C.ResourceT IO) () -> NC.RequestBody)
 signV4Stream !payloadLength !sp !req =
   let ts = spTimeStamp sp
-      addContentEncoding hs =
+
-        let ceMay = find (\(x, _) -> x == "content-encoding") hs
+      -- compute the updated list of headers to be added for signing purposes.
-         in case ceMay of
-              Nothing -> ("content-encoding", "aws-chunked") : hs
-              Just (_, ce) ->
-                ("content-encoding", ce <> ",aws-chunked")
-                  : filter (\(x, _) -> x /= "content-encoding") hs
-      -- headers to be added to the request
-      datePair = ("X-Amz-Date", awsTimeFormatBS ts)
-      computedHeaders =
-        addContentEncoding $
-          datePair : NC.requestHeaders req
-      -- headers specific to streaming signature
       signedContentLength = signedStreamLength payloadLength
-      streamingHeaders :: [Header]
+      extraHeaders =
-      streamingHeaders =
+        [ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),
-        [ ("x-amz-decoded-content-length", showBS payloadLength),
+          ("x-amz-decoded-content-length", showBS payloadLength),
           ("content-length", showBS signedContentLength),
           ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
         ]
-      headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders
+      requestHeaders =
-      signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
+        addContentEncoding $
-      finalQP = parseQuery (NC.queryString req)
+          foldr setHeader (NC.requestHeaders req) extraHeaders
+
       -- 1. Compute Seed Signature
       -- 1.1 Canonical Request
-      canonicalReq =
+      (canonicalReq, signedHeaderKeys) =
-        mkCanonicalRequest
+        getCanonicalRequestAndSignedHeaders
-          True
+          (IsStreamingLength payloadLength)
           sp
-          (NC.setQueryString finalQP req)
+          req
-          headersToSign
+          requestHeaders
-      region = fromMaybe "" $ spRegion sp
+
-      scope = mkScope ts region
+      scope = credentialScope sp
       accessKey = spAccessKey sp
-      secretKey = spSecretKey sp
       -- 1.2 String toSign
       stringToSign = mkStringToSign ts scope canonicalReq
       -- 1.3 Compute signature
       -- 1.3.1 compute signing key
-      signingKey = mkSigningKey ts region $ encodeUtf8 secretKey
+      signingKey = getSigningKey sp
       -- 1.3.2 Compute signature
       seedSignature = computeSignature stringToSign signingKey
       -- 1.3.3 Compute Auth Header
       authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature
       -- 1.4 Updated headers for the request
-      finalReqHeaders = authHeader : (computedHeaders ++ streamingHeaders)
+      finalReqHeaders = authHeader : requestHeaders
       -- headersToAdd = authHeader : datePair : streamingHeaders
 
       toHexStr n = B8.pack $ printf "%x" n
@@ -407,3 +496,9 @@ signV4Stream !payloadLength !sp !req =
               NC.requestBodySource signedContentLength $
                 src C..| signerConduit numParts lastPSize seedSignature
           }
+
+-- "setHeader r hdr" adds the hdr to r, replacing it in r if it already exists.
+setHeader :: Header -> RequestHeaders -> RequestHeaders
+setHeader hdr r =
+  let r' = filter (\(name, _) -> name /= fst hdr) r
+   in hdr : r'

src/Network/Minio/XmlParser.hs

@@ -27,9 +27,11 @@ 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)
@@ -220,8 +222,8 @@ parseListPartsResponse xmldata = do
 parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr
 parseErrResponse xmldata = do
   r <- parseRoot xmldata
-  let code = T.concat $ r $/ element "Code" &/ content
+  let code = T.concat $ r $/ laxElement "Code" &/ content
-      message = T.concat $ r $/ element "Message" &/ content
+      message = T.concat $ r $/ laxElement "Message" &/ content
   return $ toServiceErr code message
 
 parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification
@@ -269,3 +271,102 @@ 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

@@ -279,7 +279,8 @@ lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
     fGetObject bucket object destFile defaultGetObjectOptions
     gotSize <- withNewHandle destFile getFileSize
     liftIO $
-      gotSize == Right (Just mb15)
+      gotSize
+        == Right (Just mb15)
         @? "Wrong file size of put file after getting"
 
     step "Cleanup actions"
@@ -303,7 +304,8 @@ putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $
     fGetObject bucket obj destFile defaultGetObjectOptions
     gotSize <- withNewHandle destFile getFileSize
     liftIO $
-      gotSize == Right (Just mb1)
+      gotSize
+        == Right (Just mb1)
         @? "Wrong file size of put file after getting"
 
     step "Cleanup actions"
@@ -327,7 +329,8 @@ putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no siz
     fGetObject bucket obj destFile defaultGetObjectOptions
     gotSize <- withNewHandle destFile getFileSize
     liftIO $
-      gotSize == Right (Just mb70)
+      gotSize
+        == Right (Just mb70)
         @? "Wrong file size of put file after getting"
 
     step "Cleanup actions"
@@ -569,6 +572,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
         []
         []
 
+    print putUrl
     let size1 = 1000 :: Int64
     inputFile <- mkRandFile size1
 
@@ -1176,7 +1180,8 @@ getNPutSSECTest =
 
         gotSize <- withNewHandle dstFile getFileSize
         liftIO $
-          gotSize == Right (Just mb1)
+          gotSize
+            == Right (Just mb1)
             @? "Wrong file size of object when getting"
 
         step "Cleanup"