f4ae554 · typeable/minio-hs

git.iko.soy/typeable/minio-hs

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.

commitf4ae55468e7d7aea9e89214a985ccb0dd9f4ddbf authorAditya Manthramurthy <donatello@users.noreply.github.com> dateFri 23 Dec 2022, 07:53 (4 years ago) parentd87d67b

11 files changed+664−177

compare with master

unifiedsplit

.github/workflows/ci.yml+1−1 examples/AssumeRole.hs+33 minio-hs.cabal+7 src/Network/Minio/API.hs+7−5 src/Network/Minio/AdminAPI.hs+120−60 src/Network/Minio/Credentials.hs+144 src/Network/Minio/Data.hs+48−9 src/Network/Minio/PresignedOperations.hs+9−8 src/Network/Minio/Sign/V4.hs+183−88 src/Network/Minio/XmlParser.hs+103−2 test/LiveServer.hs+9−4

.github/workflows/ci.yml+1−1

@@ -25,7 +25,7 @@ jobs:

2525 runs-on: ubuntu-latest

2626 steps:

2727 - uses: actions/checkout@v3

28− - uses: mrkkrp/ormolu-action@v6

28+ - uses: mrkkrp/ormolu-action@v8

2929

3030 hlint:

3131 runs-on: ubuntu-latest

examples/AssumeRole.hsnew file+33

@@ -0,0 +1,33 @@

1+--

3+--

4+-- Licensed under the Apache License, Version 2.0 (the "License");

5+-- you may not use this file except in compliance with the License.

6+-- You may obtain a copy of the License at

7+--

8+-- http://www.apache.org/licenses/LICENSE-2.0

9+--

10+-- Unless required by applicable law or agreed to in writing, software

11+-- distributed under the License is distributed on an "AS IS" BASIS,

12+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.

13+-- See the License for the specific language governing permissions and

14+-- limitations under the License.

15+--

16+{-# LANGUAGE OverloadedStrings #-}

17+

18+import Network.Minio.Credentials

19+import Prelude

20+

21+main :: IO ()

22+main = do

23+ res <-

24+ retrieveCredentials

25+ $ STSAssumeRole

26+ "https://play.min.io"

27+ ( CredentialValue

28+ "Q3AM3UQ867SPQQA43P2F"

29+ "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"

30+ Nothing

31+ )

32+ $ defaultSTSAssumeRoleOptions {saroLocation = Just "us-east-1"}

33+ print res

minio-hs.cabal+7

@@ -128,6 +128,7 @@ common base-settings

128128 , retry

129129 , text >= 1.2

130130 , time >= 1.9

131+ , time-units ^>= 1.0.0

131132 , transformers >= 0.5

132133 , unliftio >= 0.2 && < 0.3

133134 , unliftio-core >= 0.2 && < 0.3

@@ -140,6 +141,7 @@ library

140141 exposed-modules: Network.Minio

141142 , Network.Minio.AdminAPI

142143 , Network.Minio.S3API

144+ , Network.Minio.Credentials

143145

144146Flag live-test

145147 Description: Build the test suite that runs against a live MinIO server

@@ -339,3 +341,8 @@ executable SetConfig

339341 import: examples-settings

340342 scope: private

341343 main-is: SetConfig.hs

344+

345+executable AssumeRole

346+ import: examples-settings

347+ scope: private

348+ main-is: AssumeRole.hs

src/Network/Minio/API.hs+7−5

@@ -34,6 +34,7 @@ import Control.Retry

3434 limitRetriesByCumulativeDelay,

3535 retrying,

3636 )

37+import qualified Data.ByteArray as BA

3738import qualified Data.ByteString as B

3839import qualified Data.Char as C

3940import qualified Data.Conduit as C

@@ -44,6 +45,7 @@ import Lib.Prelude

4445import qualified Network.HTTP.Client as NClient

4546import Network.HTTP.Conduit (Response)

4647import qualified Network.HTTP.Conduit as NC

48+import Network.HTTP.Types (simpleQueryToQuery)

4749import qualified Network.HTTP.Types as HT

4850import Network.HTTP.Types.Header (hHost)

4951import Network.Minio.APICommon

@@ -176,7 +178,8 @@ buildRequest ri = do

176178 let sp =

177179 SignParams

178180 (connectAccessKey ci')

179− (connectSecretKey ci')

181+ (BA.convert (encodeUtf8 $ connectSecretKey ci' :: ByteString))

182+ ServiceS3

180183 timeStamp

181184 (riRegion ri')

182185 (riPresignExpirySecs ri')

@@ -198,8 +201,8 @@ buildRequest ri = do

198201 | isJust (riPresignExpirySecs ri') ->

199202 -- case 0 from above.

200203 do

201− let signPairs = signV4 sp baseRequest

202− qpToAdd = (fmap . fmap) Just signPairs

204+ let signPairs = signV4QueryParams sp baseRequest

205+ qpToAdd = simpleQueryToQuery signPairs

203206 existingQueryParams = HT.parseQuery (NC.queryString baseRequest)

204207 updatedQueryParams = existingQueryParams ++ qpToAdd

205208 return $ NClient.setQueryString updatedQueryParams baseRequest

@@ -229,8 +232,7 @@ buildRequest ri = do

229232 return $

230233 baseRequest

231234 { NC.requestHeaders =

232− NC.requestHeaders baseRequest

233− ++ mkHeaderFromPairs signHeaders,

235+ NC.requestHeaders baseRequest ++ signHeaders,

234236 NC.requestBody = getRequestBody (riPayload ri')

235237 }

236238

src/Network/Minio/AdminAPI.hs+120−60

@@ -70,6 +70,7 @@ import Data.Aeson

7070 )

7171import qualified Data.Aeson as A

7272import Data.Aeson.Types (typeMismatch)

73+import qualified Data.ByteArray as BA

7374import qualified Data.ByteString as B

7475import qualified Data.ByteString.Lazy as LBS

7576import qualified Data.Text as T

@@ -95,9 +96,12 @@ data DriveInfo = DriveInfo

9596instance FromJSON DriveInfo where

9697 parseJSON = withObject "DriveInfo" $ \v ->

9798 DriveInfo

98− <$> v .: "uuid"

99− <*> v .: "endpoint"

100− <*> v .: "state"

99+ <$> v

100+ .: "uuid"

101+ <*> v

102+ .: "endpoint"

103+ <*> v

104+ .: "state"

101105

102106data StorageClass = StorageClass

103107 { scParity :: Int,

@@ -120,12 +124,16 @@ instance FromJSON ErasureInfo where

120124 offlineDisks <- v .: "OfflineDisks"

121125 stdClass <-

122126 StorageClass

123− <$> v .: "StandardSCData"

124− <*> v .: "StandardSCParity"

127+ <$> v

128+ .: "StandardSCData"

129+ <*> v

130+ .: "StandardSCParity"

125131 rrClass <-

126132 StorageClass

127− <$> v .: "RRSCData"

128− <*> v .: "RRSCParity"

133+ <$> v

134+ .: "RRSCData"

135+ <*> v

136+ .: "RRSCParity"

129137 sets <- v .: "Sets"

130138 return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets

131139

@@ -151,8 +159,10 @@ data ConnStats = ConnStats

151159instance FromJSON ConnStats where

152160 parseJSON = withObject "ConnStats" $ \v ->

153161 ConnStats

154− <$> v .: "transferred"

155− <*> v .: "received"

162+ <$> v

163+ .: "transferred"

164+ <*> v

165+ .: "received"

156166

157167data ServerProps = ServerProps

158168 { spUptime :: NominalDiffTime,

@@ -182,8 +192,10 @@ data StorageInfo = StorageInfo

182192instance FromJSON StorageInfo where

183193 parseJSON = withObject "StorageInfo" $ \v ->

184194 StorageInfo

185− <$> v .: "Used"

186− <*> v .: "Backend"

195+ <$> v

196+ .: "Used"

197+ <*> v

198+ .: "Backend"

187199

188200data CountNAvgTime = CountNAvgTime

189201 { caCount :: Int64,

@@ -194,8 +206,10 @@ data CountNAvgTime = CountNAvgTime

194206instance FromJSON CountNAvgTime where

195207 parseJSON = withObject "CountNAvgTime" $ \v ->

196208 CountNAvgTime

197− <$> v .: "count"

198− <*> v .: "avgDuration"

209+ <$> v

210+ .: "count"

211+ <*> v

212+ .: "avgDuration"

199213

200214data HttpStats = HttpStats

201215 { hsTotalHeads :: CountNAvgTime,

@@ -214,16 +228,26 @@ data HttpStats = HttpStats

214228instance FromJSON HttpStats where

215229 parseJSON = withObject "HttpStats" $ \v ->

216230 HttpStats

217− <$> v .: "totalHEADs"

218− <*> v .: "successHEADs"

219− <*> v .: "totalGETs"

220− <*> v .: "successGETs"

221− <*> v .: "totalPUTs"

222− <*> v .: "successPUTs"

223− <*> v .: "totalPOSTs"

224− <*> v .: "successPOSTs"

225− <*> v .: "totalDELETEs"

226− <*> v .: "successDELETEs"

231+ <$> v

232+ .: "totalHEADs"

233+ <*> v

234+ .: "successHEADs"

235+ <*> v

236+ .: "totalGETs"

237+ <*> v

238+ .: "successGETs"

239+ <*> v

240+ .: "totalPUTs"

241+ <*> v

242+ .: "successPUTs"

243+ <*> v

244+ .: "totalPOSTs"

245+ <*> v

246+ .: "successPOSTs"

247+ <*> v

248+ .: "totalDELETEs"

249+ <*> v

250+ .: "successDELETEs"

227251

228252data SIData = SIData

229253 { sdStorage :: StorageInfo,

@@ -236,10 +260,14 @@ data SIData = SIData

236260instance FromJSON SIData where

237261 parseJSON = withObject "SIData" $ \v ->

238262 SIData

239− <$> v .: "storage"

240− <*> v .: "network"

241− <*> v .: "http"

242− <*> v .: "server"

263+ <$> v

264+ .: "storage"

265+ <*> v

266+ .: "network"

267+ <*> v

268+ .: "http"

269+ <*> v

270+ .: "server"

243271

244272data ServerInfo = ServerInfo

245273 { siError :: Text,

@@ -251,9 +279,12 @@ data ServerInfo = ServerInfo

251279instance FromJSON ServerInfo where

252280 parseJSON = withObject "ServerInfo" $ \v ->

253281 ServerInfo

254− <$> v .: "error"

255− <*> v .: "addr"

256− <*> v .: "data"

282+ <$> v

283+ .: "error"

284+ <*> v

285+ .: "addr"

286+ <*> v

287+ .: "data"

257288

258289data ServerVersion = ServerVersion

259290 { svVersion :: Text,

@@ -264,8 +295,10 @@ data ServerVersion = ServerVersion

264295instance FromJSON ServerVersion where

265296 parseJSON = withObject "ServerVersion" $ \v ->

266297 ServerVersion

267− <$> v .: "version"

268− <*> v .: "commitID"

298+ <$> v

299+ .: "version"

300+ <*> v

301+ .: "commitID"

269302

270303data ServiceStatus = ServiceStatus

271304 { ssVersion :: ServerVersion,

@@ -306,9 +339,12 @@ data HealStartResp = HealStartResp

306339instance FromJSON HealStartResp where

307340 parseJSON = withObject "HealStartResp" $ \v ->

308341 HealStartResp

309− <$> v .: "clientToken"

310− <*> v .: "clientAddress"

311− <*> v .: "startTime"

342+ <$> v

343+ .: "clientToken"

344+ <*> v

345+ .: "clientAddress"

346+ <*> v

347+ .: "startTime"

312348

313349data HealOpts = HealOpts

314350 { hoRecursive :: Bool,

@@ -325,8 +361,10 @@ instance ToJSON HealOpts where

325361instance FromJSON HealOpts where

326362 parseJSON = withObject "HealOpts" $ \v ->

327363 HealOpts

328− <$> v .: "recursive"

329− <*> v .: "dryRun"

364+ <$> v

365+ .: "recursive"

366+ <*> v

367+ .: "dryRun"

330368

331369data HealItemType

332370 = HealItemMetadata

@@ -353,9 +391,12 @@ data NodeSummary = NodeSummary

353391instance FromJSON NodeSummary where

354392 parseJSON = withObject "NodeSummary" $ \v ->

355393 NodeSummary

356− <$> v .: "name"

357− <*> v .: "errSet"

358− <*> v .: "errMsg"

394+ <$> v

395+ .: "name"

396+ <*> v

397+ .: "errSet"

398+ <*> v

399+ .: "errMsg"

359400

360401data SetConfigResult = SetConfigResult

361402 { scrStatus :: Bool,

@@ -366,8 +407,10 @@ data SetConfigResult = SetConfigResult

366407instance FromJSON SetConfigResult where

367408 parseJSON = withObject "SetConfigResult" $ \v ->

368409 SetConfigResult

369− <$> v .: "status"

370− <*> v .: "nodeResults"

410+ <$> v

411+ .: "status"

412+ <*> v

413+ .: "nodeResults"

371414

372415data HealResultItem = HealResultItem

373416 { hriResultIdx :: Int,

@@ -388,16 +431,26 @@ data HealResultItem = HealResultItem

388431instance FromJSON HealResultItem where

389432 parseJSON = withObject "HealResultItem" $ \v ->

390433 HealResultItem

391− <$> v .: "resultId"

392− <*> v .: "type"

393− <*> v .: "bucket"

394− <*> v .: "object"

395− <*> v .: "detail"

396− <*> v .:? "parityBlocks"

397− <*> v .:? "dataBlocks"

398− <*> v .: "diskCount"

399− <*> v .: "setCount"

400− <*> v .: "objectSize"

434+ <$> v

435+ .: "resultId"

436+ <*> v

437+ .: "type"

438+ <*> v

439+ .: "bucket"

440+ <*> v

441+ .: "object"

442+ <*> v

443+ .: "detail"

444+ <*> v

445+ .:? "parityBlocks"

446+ <*> v

447+ .:? "dataBlocks"

448+ <*> v

449+ .: "diskCount"

450+ <*> v

451+ .: "setCount"

452+ <*> v

453+ .: "objectSize"

401454 <*> ( do

402455 before <- v .: "before"

403456 before .: "drives"

@@ -420,12 +473,18 @@ data HealStatus = HealStatus

420473instance FromJSON HealStatus where

421474 parseJSON = withObject "HealStatus" $ \v ->

422475 HealStatus

423− <$> v .: "Summary"

424− <*> v .: "StartTime"

425− <*> v .: "Settings"

426− <*> v .: "NumDisks"

427− <*> v .:? "Detail"

428− <*> v .: "Items"

476+ <$> v

477+ .: "Summary"

478+ <*> v

479+ .: "StartTime"

480+ <*> v

481+ .: "Settings"

482+ <*> v

483+ .: "NumDisks"

484+ <*> v

485+ .:? "Detail"

486+ <*> v

487+ .: "Items"

429488

430489healPath :: Maybe Bucket -> Maybe Text -> ByteString

431490healPath bucket prefix = do

@@ -620,7 +679,8 @@ buildAdminRequest areq = do

620679 sp =

621680 SignParams

622681 (connectAccessKey ci)

623− (connectSecretKey ci)

682+ (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString))

683+ ServiceS3

624684 timeStamp

625685 Nothing

626686 Nothing

@@ -630,7 +690,7 @@ buildAdminRequest areq = do

630690 -- Update signReq with Authorization header containing v4 signature

631691 return

632692 signReq

633− { NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders

693+ { NC.requestHeaders = ariHeaders newAreq ++ signHeaders

634694 }

635695 where

636696 toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request

src/Network/Minio/Credentials.hsnew file+144

@@ -0,0 +1,144 @@

1+--

3+--

4+-- Licensed under the Apache License, Version 2.0 (the "License");

5+-- you may not use this file except in compliance with the License.

6+-- You may obtain a copy of the License at

7+--

8+-- http://www.apache.org/licenses/LICENSE-2.0

9+--

10+-- Unless required by applicable law or agreed to in writing, software

11+-- distributed under the License is distributed on an "AS IS" BASIS,

12+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.

13+-- See the License for the specific language governing permissions and

14+-- limitations under the License.

15+--

16+

17+module Network.Minio.Credentials

18+ ( CredentialValue (..),

19+ CredentialProvider (..),

20+ AccessKey,

21+ SecretKey,

22+ SessionToken,

23+ defaultSTSAssumeRoleOptions,

24+ STSAssumeRole (..),

25+ STSAssumeRoleOptions (..),

26+ )

27+where

28+

29+import qualified Data.Time as Time

30+import Data.Time.Units (Second)

31+import Network.HTTP.Client (RequestBody (RequestBodyBS))

32+import qualified Network.HTTP.Client as NC

33+import qualified Network.HTTP.Client.TLS as NC

34+import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery)

35+import Network.HTTP.Types.Header (hHost)

36+import Network.Minio.Data

37+import Network.Minio.Data.Crypto (hashSHA256)

38+import Network.Minio.Sign.V4

39+import Network.Minio.Utils (httpLbs)

40+import Network.Minio.XmlParser (parseSTSAssumeRoleResult)

41+

42+class CredentialProvider p where

43+ retrieveCredentials :: p -> IO CredentialValue

44+

45+stsVersion :: ByteString

46+stsVersion = "2011-06-15"

47+

48+defaultDurationSeconds :: Second

49+defaultDurationSeconds = 3600

50+

51+data STSAssumeRole = STSAssumeRole

52+ { sarEndpoint :: Text,

53+ sarCredentials :: CredentialValue,

54+ sarOptions :: STSAssumeRoleOptions

55+ }

56+

57+data STSAssumeRoleOptions = STSAssumeRoleOptions

58+ { -- | Desired validity for the generated credentials.

59+ saroDurationSeconds :: Maybe Second,

60+ -- | IAM policy to apply for the generated credentials.

61+ saroPolicyJSON :: Maybe ByteString,

62+ -- | Location is usually required for AWS.

63+ saroLocation :: Maybe Text,

64+ saroRoleARN :: Maybe Text,

65+ saroRoleSessionName :: Maybe Text,

66+ -- | Optional HTTP connection manager

67+ saroHTTPManager :: Maybe NC.Manager

68+ }

69+

70+-- | Default STS Assume Role options

71+defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions

72+defaultSTSAssumeRoleOptions =

73+ STSAssumeRoleOptions

74+ { saroDurationSeconds = Just defaultDurationSeconds,

75+ saroPolicyJSON = Nothing,

76+ saroLocation = Nothing,

77+ saroRoleARN = Nothing,

78+ saroRoleSessionName = Nothing,

79+ saroHTTPManager = Nothing

80+ }

81+

82+instance CredentialProvider STSAssumeRole where

83+ retrieveCredentials sar = do

84+ -- Assemble STS request

85+ let requiredParams =

86+ [ ("Action", "AssumeRole"),

87+ ("Version", stsVersion)

88+ ]

89+ opts = sarOptions sar

90+ durSecs :: Int =

91+ fromIntegral $

92+ fromMaybe defaultDurationSeconds $

93+ saroDurationSeconds opts

94+ otherParams =

95+ [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts,

96+ ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts,

97+ Just ("DurationSeconds", show durSecs),

98+ ("Policy",) <$> saroPolicyJSON opts

99+ ]

100+ parameters = requiredParams ++ catMaybes otherParams

101+ (host, port, isSecure) =

102+ let endPt = NC.parseRequest_ $ toString $ sarEndpoint sar

103+ in (NC.host endPt, NC.port endPt, NC.secure endPt)

104+ reqBody = renderSimpleQuery False parameters

105+ req =

106+ NC.defaultRequest

107+ { NC.host = host,

108+ NC.port = port,

109+ NC.secure = isSecure,

110+ NC.method = methodPost,

111+ NC.requestHeaders =

112+ [ (hHost, getHostHeader (host, port)),

113+ (hContentType, "application/x-www-form-urlencoded")

114+ ],

115+ NC.requestBody = RequestBodyBS reqBody

116+ }

117+

118+ -- Sign the STS request.

119+ timeStamp <- liftIO Time.getCurrentTime

120+ let sp =

121+ SignParams

122+ { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar,

123+ spSecretKey = coerce $ cvSecretKey $ sarCredentials sar,

124+ spService = ServiceSTS,

125+ spTimeStamp = timeStamp,

126+ spRegion = saroLocation opts,

127+ spExpirySecs = Nothing,

128+ spPayloadHash = Just $ hashSHA256 reqBody

129+ }

130+ signHeaders = signV4 sp req

131+ signedReq =

132+ req

133+ { NC.requestHeaders = NC.requestHeaders req ++ signHeaders

134+ }

135+ settings = bool NC.defaultManagerSettings NC.tlsManagerSettings isSecure

136+

137+ -- Make the STS request

138+ mgr <- maybe (NC.newManager settings) return $ saroHTTPManager opts

139+ resp <- httpLbs signedReq mgr

140+ result <-

141+ parseSTSAssumeRoleResult

142+ (toStrict $ NC.responseBody resp)

143+ "https://sts.amazonaws.com/doc/2011-06-15/"

144+ return $ arcCredentials $ arrRoleCredentials result

src/Network/Minio/Data.hs+48−9

@@ -232,16 +232,14 @@ isConnectInfoSecure = connectIsSecure

232232disableTLSCertValidation :: ConnectInfo -> ConnectInfo

233233disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}

234234

235−getHostAddr :: ConnectInfo -> ByteString

236−getHostAddr ci =

235+getHostHeader :: (ByteString, Int) -> ByteString

236+getHostHeader (host, port) =

237237 if port == 80 || port == 443

238− then encodeUtf8 host

239− else

240− encodeUtf8 $

241− T.concat [host, ":", show port]

242− where

243− port = connectPort ci

244− host = connectHost ci

238+ then host

239+ else host <> ":" <> show port

240+

241+getHostAddr :: ConnectInfo -> ByteString

242+getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort ci)

245243

246244-- | Default Google Compute Storage ConnectInfo. Works only for

247245-- "Simple Migration" use-case with interoperability mode enabled on

@@ -1002,6 +1000,47 @@ type Stats = Progress

10021000-- Select API Related Types End

10031001--------------------------------------------------------------------------

10041002

1003+----------------------------------------

1004+-- Credentials Start

1005+----------------------------------------

1006+

1007+newtype AccessKey = AccessKey {unAccessKey :: Text}

1008+ deriving stock (Show)

1009+ deriving newtype (Eq, IsString)

1010+

1011+newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes}

1012+ deriving stock (Show)

1013+ deriving newtype (Eq, IsString)

1014+

1015+newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes}

1016+ deriving stock (Show)

1017+ deriving newtype (Eq, IsString)

1018+

1019+data CredentialValue = CredentialValue

1020+ { cvAccessKey :: AccessKey,

1021+ cvSecretKey :: SecretKey,

1022+ cvSessionToken :: Maybe SessionToken

1023+ }

1024+ deriving stock (Eq, Show)

1025+

1026+data AssumeRoleCredentials = AssumeRoleCredentials

1027+ { arcCredentials :: CredentialValue,

1028+ arcExpiration :: UTCTime

1029+ }

1030+ deriving stock (Show, Eq)

1031+

1032+data AssumeRoleResult = AssumeRoleResult

1033+ { arrSourceIdentity :: Text,

1034+ arrAssumedRoleArn :: Text,

1035+ arrAssumedRoleId :: Text,

1036+ arrRoleCredentials :: AssumeRoleCredentials

1037+ }

1038+ deriving stock (Show, Eq)

1039+

1040+----------------------------------------

1041+-- Credentials End

1042+----------------------------------------

1043+

10051044-- | Represents different kinds of payload that are used with S3 API

10061045-- requests.

10071046data Payload

src/Network/Minio/PresignedOperations.hs+9−8

@@ -39,6 +39,7 @@ where

3939

4040import Data.Aeson ((.=))

4141import qualified Data.Aeson as Json

42+import qualified Data.ByteArray as BA

4243import Data.ByteString.Builder (byteString, toLazyByteString)

4344import qualified Data.HashMap.Strict as H

4445import qualified Data.Text as T

@@ -300,7 +301,7 @@ presignedPostPolicy p = do

300301 ci <- asks mcConnInfo

301302 signTime <- liftIO Time.getCurrentTime

302303

303− let extraConditions =

304+ let extraConditions signParams =

304305 [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),

305306 PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",

306307 PPCEquals

@@ -308,23 +309,24 @@ presignedPostPolicy p = do

308309 ( T.intercalate

309310 "/"

310311 [ connectAccessKey ci,

311− decodeUtf8 $ mkScope signTime region

312+ decodeUtf8 $ credentialScope signParams

312313 ]

313314 )

314315 ]

315− ppWithCreds =

316+ ppWithCreds signParams =

316317 p

317− { conditions = conditions p ++ extraConditions

318+ { conditions = conditions p ++ extraConditions signParams

318319 }

319320 sp =

320321 SignParams

321322 (connectAccessKey ci)

322− (connectSecretKey ci)

323+ (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString))

324+ ServiceS3

323325 signTime

324326 (Just $ connectRegion ci)

325327 Nothing

326328 Nothing

327− signData = signV4PostPolicy (showPostPolicy ppWithCreds) sp

329+ signData = signV4PostPolicy (showPostPolicy $ ppWithCreds sp) sp

328330 -- compute form-data

329331 mkPair (PPCStartsWith k v) = Just (k, v)

330332 mkPair (PPCEquals k v) = Just (k, v)

@@ -334,12 +336,11 @@ presignedPostPolicy p = do

334336 H.fromList $

335337 mapMaybe

336338 mkPair

337− (conditions ppWithCreds)

339+ (conditions $ ppWithCreds sp)

338340 formData = formFromPolicy `H.union` signData

339341 -- compute POST upload URL

340342 bucket = H.lookupDefault "" "bucket" formData

341343 scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci

342− region = connectRegion ci

343344 url =

344345 toStrictBS $

345346 toLazyByteString $

src/Network/Minio/Sign/V4.hs+183−88

@@ -18,19 +18,22 @@

1818module Network.Minio.Sign.V4 where

1919

2020import qualified Conduit as C

21+import qualified Data.ByteArray as BA

2122import qualified Data.ByteString as B

2223import qualified Data.ByteString.Base64 as Base64

2324import qualified Data.ByteString.Char8 as B8

2425import qualified Data.ByteString.Lazy as LB

25−import Data.CaseInsensitive (mk)

2626import qualified Data.CaseInsensitive as CI

2727import qualified Data.HashMap.Strict as Map

2828import qualified Data.HashSet as Set

29+import Data.List (partition)

30+import qualified Data.List.NonEmpty as NE

2931import qualified Data.Time as Time

3032import Lib.Prelude

3133import qualified Network.HTTP.Conduit as NC

32−import Network.HTTP.Types (Header, parseQuery)

34+import Network.HTTP.Types (Header, SimpleQuery, hContentEncoding, parseQuery)

3335import qualified Network.HTTP.Types as H

36+import Network.HTTP.Types.Header (RequestHeaders)

3437import Network.Minio.Data.ByteString

3538import Network.Minio.Data.Crypto

3639import Network.Minio.Data.Time

@@ -60,9 +63,17 @@ data SignV4Data = SignV4Data

6063 }

6164 deriving stock (Show)

6265

66+data Service = ServiceS3 | ServiceSTS

67+ deriving stock (Eq, Show)

68+

69+toByteString :: Service -> ByteString

70+toByteString ServiceS3 = "s3"

71+toByteString ServiceSTS = "sts"

72+

6373data SignParams = SignParams

6474 { spAccessKey :: Text,

65− spSecretKey :: Text,

75+ spSecretKey :: BA.ScrubbedBytes,

76+ spService :: Service,

6677 spTimeStamp :: UTCTime,

6778 spRegion :: Maybe Text,

6879 spExpirySecs :: Maybe UrlExpiry,

@@ -102,6 +113,9 @@ mkAuthHeader accessKey scope signedHeaderKeys sign =

102113 ]

103114 in (H.hAuthorization, authValue)

104115

116+data IsStreaming = IsStreamingLength Int64 | NotStreaming

117+ deriving stock (Eq, Show)

118+

105119-- | Given SignParams and request details, including request method,

106120-- request path, headers, query params and payload hash, generates an

107121-- updated set of headers, including the x-amz-date header and the

@@ -114,33 +128,19 @@ mkAuthHeader accessKey scope signedHeaderKeys sign =

114128-- is being created. The expiry is interpreted as an integer number of

115129-- seconds. The output will be the list of query-parameters to add to

116130-- the request.

117−signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]

118−signV4 !sp !req =

119− let region = fromMaybe "" $ spRegion sp

120− ts = spTimeStamp sp

121− scope = mkScope ts region

122− accessKey = encodeUtf8 $ spAccessKey sp

123− secretKey = encodeUtf8 $ spSecretKey sp

131+signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery

132+signV4QueryParams !sp !req =

133+ let scope = credentialScope sp

124134 expiry = spExpirySecs sp

125− sha256Hdr =

126− ( "x-amz-content-sha256",

127− fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp

128− )

129− -- headers to be added to the request

130− datePair = ("X-Amz-Date", awsTimeFormatBS ts)

131− computedHeaders =

132− NC.requestHeaders req

133− ++ if isJust expiry

134− then []

135− else map (first mk) [datePair, sha256Hdr]

136− headersToSign = getHeadersToSign computedHeaders

135+

136+ headersToSign = getHeadersToSign $ NC.requestHeaders req

137137 signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign

138138 -- query-parameters to be added before signing for presigned URLs

139139 -- (i.e. when `isJust expiry`)

140140 authQP =

141141 [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"),

142− ("X-Amz-Credential", B.concat [accessKey, "/", scope]),

143− datePair,

142+ ("X-Amz-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]),

143+ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),

144144 ("X-Amz-Expires", maybe "" showBS expiry),

145145 ("X-Amz-SignedHeaders", signedHeaderKeys)

146146 ]

@@ -156,40 +156,129 @@ signV4 !sp !req =

156156 sp

157157 (NC.setQueryString finalQP req)

158158 headersToSign

159+

159160 -- 2. compute string to sign

160− stringToSign = mkStringToSign ts scope canonicalRequest

161+ stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest

161162 -- 3.1 compute signing key

162− signingKey = mkSigningKey ts region secretKey

163+ signingKey = getSigningKey sp

164+ -- 3.2 compute signature

165+ signature = computeSignature stringToSign signingKey

166+ in ("X-Amz-Signature", signature) : authQP

167+

168+-- | Given SignParams and request details, including request method, request

169+-- path, headers, query params and payload hash, generates an updated set of

170+-- headers, including the x-amz-date header and the Authorization header, which

171+-- includes the signature.

172+--

173+-- The output is the list of headers to be added to authenticate the request.

174+signV4 :: SignParams -> NC.Request -> [Header]

175+signV4 !sp !req =

176+ let scope = credentialScope sp

177+

178+ -- extra headers to be added for signing purposes.

179+ extraHeaders =

180+ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp)

181+ : ( -- payload hash is only used for S3 (not STS)

182+ [ ( "x-amz-content-sha256",

183+ fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp

184+ )

185+ | spService sp == ServiceS3

186+ ]

187+ )

188+

189+ -- 1. compute canonical request

190+ reqHeaders = NC.requestHeaders req ++ extraHeaders

191+ (canonicalRequest, signedHeaderKeys) =

192+ getCanonicalRequestAndSignedHeaders

193+ NotStreaming

194+ sp

195+ req

196+ reqHeaders

197+

198+ -- 2. compute string to sign

199+ stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest

200+ -- 3.1 compute signing key

201+ signingKey = getSigningKey sp

163202 -- 3.2 compute signature

164203 signature = computeSignature stringToSign signingKey

165204 -- 4. compute auth header

166205 authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature

167− -- finally compute output pairs

168− output =

169− if isJust expiry

170− then ("X-Amz-Signature", signature) : authQP

171− else

172− [ first CI.foldedCase authHeader,

173− datePair,

174− sha256Hdr

175− ]

176− in output

177−

178−mkScope :: UTCTime -> Text -> ByteString

179−mkScope ts region =

180− B.intercalate

181− "/"

182− [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,

183− encodeUtf8 region,

184− "s3",

185− "aws4_request"

186− ]

206+ in authHeader : extraHeaders

187207

208+credentialScope :: SignParams -> ByteString

209+credentialScope sp =

210+ let region = fromMaybe "" $ spRegion sp

211+ in B.intercalate

212+ "/"

213+ [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp,

214+ encodeUtf8 region,

215+ toByteString $ spService sp,

216+ "aws4_request"

217+ ]

218+

219+-- Folds header name, trims whitespace in header values, skips ignored headers

220+-- and sorts headers.

188221getHeadersToSign :: [Header] -> [(ByteString, ByteString)]

189222getHeadersToSign !h =

190223 filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $

191224 map (bimap CI.foldedCase stripBS) h

192225

226+-- | Given the list of headers in the request, computes the canonical headers

227+-- and the signed headers strings.

228+getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)

229+getCanonicalHeaders h =

230+ let -- Folds header name, trims spaces in header values, skips ignored

231+ -- headers and sorts headers by name (we must not re-order multi-valued

232+ -- headers).

233+ headersToSign =

234+ NE.toList $

235+ NE.sortBy (\a b -> compare (fst a) (fst b)) $

236+ NE.fromList $

237+ NE.filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $

238+ NE.map (bimap CI.foldedCase stripBS) h

239+

240+ canonicalHeaders = mconcat $ map (\(a, b) -> a <> ":" <> b <> "\n") headersToSign

241+ signedHeaderKeys = B.intercalate ";" $ map fst headersToSign

242+ in (canonicalHeaders, signedHeaderKeys)

243+

244+getCanonicalRequestAndSignedHeaders ::

245+ IsStreaming ->

246+ SignParams ->

247+ NC.Request ->

248+ [Header] ->

249+ (ByteString, ByteString)

250+getCanonicalRequestAndSignedHeaders isStreaming sp req requestHeaders =

251+ let httpMethod = NC.method req

252+

253+ canonicalUri = uriEncode False $ NC.path req

254+

255+ canonicalQueryString =

256+ B.intercalate "&" $

257+ map (\(x, y) -> B.concat [x, "=", y]) $

258+ sort $

259+ map

260+ ( bimap (uriEncode True) (maybe "" (uriEncode True))

261+ )

262+ (parseQuery $ NC.queryString req)

263+

264+ (canonicalHeaders, signedHeaderKeys) = getCanonicalHeaders $ NE.fromList requestHeaders

265+ payloadHashStr =

266+ case isStreaming of

267+ IsStreamingLength _ -> "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"

268+ NotStreaming -> fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp

269+

270+ canonicalRequest =

271+ B.intercalate

272+ "\n"

273+ [ httpMethod,

274+ canonicalUri,

275+ canonicalQueryString,

276+ canonicalHeaders,

277+ signedHeaderKeys,

278+ payloadHashStr

279+ ]

280+ in (canonicalRequest, signedHeaderKeys)

281+

193282mkCanonicalRequest ::

194283 Bool ->

195284 SignParams ->

@@ -197,10 +286,12 @@ mkCanonicalRequest ::

197286 [(ByteString, ByteString)] ->

198287 ByteString

199288mkCanonicalRequest !isStreaming !sp !req !headersForSign =

200− let canonicalQueryString =

289+ let httpMethod = NC.method req

290+ canonicalUri = uriEncode False $ NC.path req

291+ canonicalQueryString =

201292 B.intercalate "&" $

202293 map (\(x, y) -> B.concat [x, "=", y]) $

203− sort $

294+ sortBy (\a b -> compare (fst a) (fst b)) $

204295 map

205296 ( bimap (uriEncode True) (maybe "" (uriEncode True))

206297 )

@@ -216,8 +307,8 @@ mkCanonicalRequest !isStreaming !sp !req !headersForSign =

216307 else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp

217308 in B.intercalate

218309 "\n"

219− [ NC.method req,

220− uriEncode False $ NC.path req,

310+ [ httpMethod,

311+ canonicalUri,

221312 canonicalQueryString,

222313 canonicalHeaders,

223314 signedHeaders,

@@ -234,13 +325,13 @@ mkStringToSign ts !scope !canonicalRequest =

234325 hashSHA256 canonicalRequest

235326 ]

236327

237−mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString

238−mkSigningKey ts region !secretKey =

328+getSigningKey :: SignParams -> ByteString

329+getSigningKey sp =

239330 hmacSHA256RawBS "aws4_request"

240− . hmacSHA256RawBS "s3"

241− . hmacSHA256RawBS (encodeUtf8 region)

242− . hmacSHA256RawBS (awsDateFormatBS ts)

243− $ B.concat ["AWS4", secretKey]

331+ . hmacSHA256RawBS (toByteString $ spService sp)

332+ . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp)

333+ . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp)

334+ $ B.concat ["AWS4", BA.convert $ spSecretKey sp]

244335

245336computeSignature :: ByteString -> ByteString -> ByteString

246337computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key

@@ -254,8 +345,7 @@ signV4PostPolicy ::

254345 Map.HashMap Text ByteString

255346signV4PostPolicy !postPolicyJSON !sp =

256347 let stringToSign = Base64.encode postPolicyJSON

257− region = fromMaybe "" $ spRegion sp

258− signingKey = mkSigningKey (spTimeStamp sp) region $ encodeUtf8 $ spSecretKey sp

348+ signingKey = getSigningKey sp

259349 signature = computeSignature stringToSign signingKey

260350 in Map.fromList

261351 [ ("x-amz-signature", signature),

@@ -284,60 +374,59 @@ signedStreamLength dataLen =

284374 finalChunkSize = 1 + 17 + 64 + 2 + 2

285375 in numChunks * fullChunkSize + lastChunkSize + finalChunkSize

286376

377+-- For streaming S3, we need to update the content-encoding header.

378+addContentEncoding :: [Header] -> [Header]

379+addContentEncoding hs =

380+ -- assume there is at most one content-encoding header.

381+ let (ceHdrs, others) = partition ((== hContentEncoding) . fst) hs

382+ in maybe

383+ (hContentEncoding, "aws-chunked")

384+ (\(k, v) -> (k, v <> ",aws-chunked"))

385+ (listToMaybe ceHdrs)

386+ : others

387+

287388signV4Stream ::

288389 Int64 ->

289390 SignParams ->

290391 NC.Request ->

291392 (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)

292−-- -> ([Header], C.ConduitT () ByteString (C.ResourceT IO) () -> NC.RequestBody)

293393signV4Stream !payloadLength !sp !req =

294394 let ts = spTimeStamp sp

295− addContentEncoding hs =

296− let ceMay = find (\(x, _) -> x == "content-encoding") hs

297− in case ceMay of

298− Nothing -> ("content-encoding", "aws-chunked") : hs

299− Just (_, ce) ->

300− ("content-encoding", ce <> ",aws-chunked")

301− : filter (\(x, _) -> x /= "content-encoding") hs

302− -- headers to be added to the request

303− datePair = ("X-Amz-Date", awsTimeFormatBS ts)

304− computedHeaders =

305− addContentEncoding $

306− datePair : NC.requestHeaders req

307− -- headers specific to streaming signature

395+

396+ -- compute the updated list of headers to be added for signing purposes.

308397 signedContentLength = signedStreamLength payloadLength

309− streamingHeaders :: [Header]

310− streamingHeaders =

311− [ ("x-amz-decoded-content-length", showBS payloadLength),

398+ extraHeaders =

399+ [ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),

400+ ("x-amz-decoded-content-length", showBS payloadLength),

312401 ("content-length", showBS signedContentLength),

313402 ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")

314403 ]

315− headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders

316− signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign

317− finalQP = parseQuery (NC.queryString req)

404+ requestHeaders =

405+ addContentEncoding $

406+ foldr setHeader (NC.requestHeaders req) extraHeaders

407+

318408 -- 1. Compute Seed Signature

319409 -- 1.1 Canonical Request

320− canonicalReq =

321− mkCanonicalRequest

322− True

410+ (canonicalReq, signedHeaderKeys) =

411+ getCanonicalRequestAndSignedHeaders

412+ (IsStreamingLength payloadLength)

323413 sp

324− (NC.setQueryString finalQP req)

325− headersToSign

326− region = fromMaybe "" $ spRegion sp

327− scope = mkScope ts region

414+ req

415+ requestHeaders

416+

417+ scope = credentialScope sp

328418 accessKey = spAccessKey sp

329− secretKey = spSecretKey sp

330419 -- 1.2 String toSign

331420 stringToSign = mkStringToSign ts scope canonicalReq

332421 -- 1.3 Compute signature

333422 -- 1.3.1 compute signing key

334− signingKey = mkSigningKey ts region $ encodeUtf8 secretKey

423+ signingKey = getSigningKey sp

335424 -- 1.3.2 Compute signature

336425 seedSignature = computeSignature stringToSign signingKey

337426 -- 1.3.3 Compute Auth Header

338427 authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature

339428 -- 1.4 Updated headers for the request

340− finalReqHeaders = authHeader : (computedHeaders ++ streamingHeaders)

429+ finalReqHeaders = authHeader : requestHeaders

341430 -- headersToAdd = authHeader : datePair : streamingHeaders

342431

343432 toHexStr n = B8.pack $ printf "%x" n

@@ -407,3 +496,9 @@ signV4Stream !payloadLength !sp !req =

407496 NC.requestBodySource signedContentLength $

408497 src C..| signerConduit numParts lastPSize seedSignature

409498 }

499+

500+-- "setHeader r hdr" adds the hdr to r, replacing it in r if it already exists.

501+setHeader :: Header -> RequestHeaders -> RequestHeaders

502+setHeader hdr r =

503+ let r' = filter (\(name, _) -> name /= fst hdr) r

504+ in hdr : r'

src/Network/Minio/XmlParser.hs+103−2

@@ -27,9 +27,11 @@ module Network.Minio.XmlParser

2727 parseErrResponse,

2828 parseNotification,

2929 parseSelectProgress,

30+ parseSTSAssumeRoleResult,

3031 )

3132where

3233

34+import qualified Data.ByteArray as BA

3335import qualified Data.ByteString.Lazy as LB

3436import qualified Data.HashMap.Strict as H

3537import Data.List (zip4, zip6)

@@ -220,8 +222,8 @@ parseListPartsResponse xmldata = do

220222parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr

221223parseErrResponse xmldata = do

222224 r <- parseRoot xmldata

223− let code = T.concat $ r $/ element "Code" &/ content

224− message = T.concat $ r $/ element "Message" &/ content

225+ let code = T.concat $ r $/ laxElement "Code" &/ content

226+ message = T.concat $ r $/ laxElement "Message" &/ content

225227 return $ toServiceErr code message

226228

227229parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification

@@ -269,3 +271,102 @@ parseSelectProgress xmldata = do

269271 <$> parseDecimal bScanned

270272 <*> parseDecimal bProcessed

271273 <*> parseDecimal bReturned

274+

275+-- <AssumeRoleResponse xmlns="https://sts.amazonaws.com/doc/2011-06-15/">

276+-- <AssumeRoleResult>

277+-- <SourceIdentity>Alice</SourceIdentity>

278+-- <AssumedRoleUser>

279+-- <Arn>arn:aws:sts::123456789012:assumed-role/demo/TestAR</Arn>

280+-- <AssumedRoleId>ARO123EXAMPLE123:TestAR</AssumedRoleId>

281+-- </AssumedRoleUser>

282+-- <Credentials>

283+-- <AccessKeyId>ASIAIOSFODNN7EXAMPLE</AccessKeyId>

284+-- <SecretAccessKey>wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY</SecretAccessKey>

285+-- <SessionToken>

286+-- AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW

287+-- LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd

288+-- QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU

289+-- 9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz

290+-- +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA==

291+-- </SessionToken>

292+-- <Expiration>2019-11-09T13:34:41Z</Expiration>

293+-- </Credentials>

294+-- <PackedPolicySize>6</PackedPolicySize>

295+-- </AssumeRoleResult>

296+-- <ResponseMetadata>

297+-- <RequestId>c6104cbe-af31-11e0-8154-cbc7ccf896c7</RequestId>

298+-- </ResponseMetadata>

299+-- </AssumeRoleResponse>

300+

301+parseSTSAssumeRoleResult :: MonadIO m => ByteString -> Text -> m AssumeRoleResult

302+parseSTSAssumeRoleResult xmldata namespace = do

303+ r <- parseRoot $ LB.fromStrict xmldata

304+ let s3Elem' = s3Elem namespace

305+ sourceIdentity =

306+ T.concat $

307+ r

308+ $/ s3Elem' "AssumeRoleResult"

309+ &/ s3Elem' "SourceIdentity"

310+ &/ content

311+ roleArn =

312+ T.concat $

313+ r

314+ $/ s3Elem' "AssumeRoleResult"

315+ &/ s3Elem' "AssumedRoleUser"

316+ &/ s3Elem' "Arn"

317+ &/ content

318+ roleId =

319+ T.concat $

320+ r

321+ $/ s3Elem' "AssumeRoleResult"

322+ &/ s3Elem' "AssumedRoleUser"

323+ &/ s3Elem' "AssumedRoleId"

324+ &/ content

325+

326+ convSB :: Text -> BA.ScrubbedBytes

327+ convSB = BA.convert . (encodeUtf8 :: Text -> ByteString)

328+

329+ credsInfo = do

330+ cr <-

331+ maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $

332+ listToMaybe $

333+ r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials"

334+ let cur = fromNode $ node cr

335+ return

336+ ( CredentialValue

337+ { cvAccessKey =

338+ coerce $

339+ T.concat $

340+ cur $/ s3Elem' "AccessKeyId" &/ content,

341+ cvSecretKey =

342+ coerce $

343+ convSB $

344+ T.concat $

345+ cur

346+ $/ s3Elem' "SecretAccessKey"

347+ &/ content,

348+ cvSessionToken =

349+ Just $

350+ coerce $

351+ convSB $

352+ T.concat $

353+ cur

354+ $/ s3Elem' "SessionToken"

355+ &/ content

356+ },

357+ T.concat $ cur $/ s3Elem' "Expiration" &/ content

358+ )

359+ creds <- either throwIO pure credsInfo

360+ expiry <- parseS3XMLTime $ snd creds

361+ let roleCredentials =

362+ AssumeRoleCredentials

363+ { arcCredentials = fst creds,

364+ arcExpiration = expiry

365+ }

366+ return

367+ AssumeRoleResult

368+ { arrSourceIdentity = sourceIdentity,

369+ arrAssumedRoleArn = roleArn,

370+ arrAssumedRoleId = roleId,

371+ arrRoleCredentials = roleCredentials

372+ }

test/LiveServer.hs+9−4

@@ -279,7 +279,8 @@ lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $

279279 fGetObject bucket object destFile defaultGetObjectOptions

280280 gotSize <- withNewHandle destFile getFileSize

281281 liftIO $

282− gotSize == Right (Just mb15)

282+ gotSize

283+ == Right (Just mb15)

283284 @? "Wrong file size of put file after getting"

284285

285286 step "Cleanup actions"

@@ -303,7 +304,8 @@ putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $

303304 fGetObject bucket obj destFile defaultGetObjectOptions

304305 gotSize <- withNewHandle destFile getFileSize

305306 liftIO $

306− gotSize == Right (Just mb1)

307+ gotSize

308+ == Right (Just mb1)

307309 @? "Wrong file size of put file after getting"

308310

309311 step "Cleanup actions"

@@ -327,7 +329,8 @@ putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no siz

327329 fGetObject bucket obj destFile defaultGetObjectOptions

328330 gotSize <- withNewHandle destFile getFileSize

329331 liftIO $

330− gotSize == Right (Just mb70)

332+ gotSize

333+ == Right (Just mb70)

331334 @? "Wrong file size of put file after getting"

332335

333336 step "Cleanup actions"

@@ -569,6 +572,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $

569572 []

570573 []

571574

575+ print putUrl

572576 let size1 = 1000 :: Int64

573577 inputFile <- mkRandFile size1

574578

@@ -1176,7 +1180,8 @@ getNPutSSECTest =

11761180

11771181 gotSize <- withNewHandle dstFile getFileSize

11781182 liftIO $

1179− gotSize == Right (Just mb1)

1183+ gotSize

1184+ == Right (Just mb1)

11801185 @? "Wrong file size of object when getting"

11811186

11821187 step "Cleanup"