diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0d7e171..ed3a64d 100644 --- a/.github/workflows/ci.yml +++ b/.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 diff --git a/examples/AssumeRole.hs b/examples/AssumeRole.hs new file mode 100644 index 0000000..649f517 --- /dev/null +++ b/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 diff --git a/minio-hs.cabal b/minio-hs.cabal index 45772cf..c2cb360 100644 --- a/minio-hs.cabal +++ b/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 diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index a4f7633..60a676c 100644 --- a/src/Network/Minio/API.hs +++ b/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 - qpToAdd = (fmap . fmap) Just signPairs + let signPairs = signV4QueryParams sp baseRequest + 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 - ++ mkHeaderFromPairs signHeaders, + NC.requestHeaders baseRequest ++ signHeaders, NC.requestBody = getRequestBody (riPayload ri') } diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index b15598c..c12db15 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/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 .: "endpoint" - <*> v .: "state" + <$> v + .: "uuid" + <*> 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 .: "StandardSCParity" + <$> v + .: "StandardSCData" + <*> v + .: "StandardSCParity" rrClass <- StorageClass - <$> v .: "RRSCData" - <*> v .: "RRSCParity" + <$> v + .: "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 .: "received" + <$> v + .: "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 .: "Backend" + <$> v + .: "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 .: "avgDuration" + <$> v + .: "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 .: "successHEADs" - <*> v .: "totalGETs" - <*> v .: "successGETs" - <*> v .: "totalPUTs" - <*> v .: "successPUTs" - <*> v .: "totalPOSTs" - <*> v .: "successPOSTs" - <*> v .: "totalDELETEs" - <*> v .: "successDELETEs" + <$> v + .: "totalHEADs" + <*> v + .: "successHEADs" + <*> v + .: "totalGETs" + <*> v + .: "successGETs" + <*> v + .: "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 .: "network" - <*> v .: "http" - <*> v .: "server" + <$> v + .: "storage" + <*> v + .: "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 .: "addr" - <*> v .: "data" + <$> v + .: "error" + <*> 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 .: "commitID" + <$> v + .: "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 .: "clientAddress" - <*> v .: "startTime" + <$> v + .: "clientToken" + <*> 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 .: "dryRun" + <$> v + .: "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 .: "errSet" - <*> v .: "errMsg" + <$> v + .: "name" + <*> 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 .: "nodeResults" + <$> v + .: "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 .: "type" - <*> v .: "bucket" - <*> v .: "object" - <*> v .: "detail" - <*> v .:? "parityBlocks" - <*> v .:? "dataBlocks" - <*> v .: "diskCount" - <*> v .: "setCount" - <*> v .: "objectSize" + <$> v + .: "resultId" + <*> v + .: "type" + <*> v + .: "bucket" + <*> v + .: "object" + <*> v + .: "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 .: "StartTime" - <*> v .: "Settings" - <*> v .: "NumDisks" - <*> v .:? "Detail" - <*> v .: "Items" + <$> v + .: "Summary" + <*> v + .: "StartTime" + <*> v + .: "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 diff --git a/src/Network/Minio/Credentials.hs b/src/Network/Minio/Credentials.hs new file mode 100644 index 0000000..ccbf179 --- /dev/null +++ b/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 diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 3fcd514..018c7f8 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -232,16 +232,14 @@ isConnectInfoSecure = connectIsSecure disableTLSCertValidation :: ConnectInfo -> ConnectInfo disableTLSCertValidation c = c {connectDisableTLSCertValidation = True} -getHostAddr :: ConnectInfo -> ByteString -getHostAddr ci = +getHostHeader :: (ByteString, Int) -> ByteString +getHostHeader (host, port) = if port == 80 || port == 443 - then encodeUtf8 host - else - encodeUtf8 $ - T.concat [host, ":", show port] - where - port = connectPort ci - host = connectHost ci + then host + else host <> ":" <> show port + +getHostAddr :: ConnectInfo -> ByteString +getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort 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 diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index dadca93..f651deb 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/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 $ diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 86d604b..73f9f2a 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/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)] -signV4 !sp !req = - let region = fromMaybe "" $ spRegion sp - ts = spTimeStamp sp - scope = mkScope ts region - accessKey = encodeUtf8 $ spAccessKey sp - secretKey = encodeUtf8 $ spSecretKey sp +signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery +signV4QueryParams !sp !req = + let scope = credentialScope sp expiry = spExpirySecs sp - sha256Hdr = - ( "x-amz-content-sha256", - 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 + + headersToSign = getHeadersToSign $ NC.requestHeaders req 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]), - datePair, + ("X-Amz-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]), + ("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 - output = - if isJust expiry - then ("X-Amz-Signature", signature) : authQP - else - [ first CI.foldedCase authHeader, - datePair, - sha256Hdr - ] - in output - -mkScope :: UTCTime -> Text -> ByteString -mkScope ts region = - B.intercalate - "/" - [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts, - encodeUtf8 region, - "s3", - "aws4_request" - ] + in authHeader : extraHeaders +credentialScope :: SignParams -> ByteString +credentialScope sp = + let region = fromMaybe "" $ spRegion sp + in B.intercalate + "/" + [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp, + encodeUtf8 region, + 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, - uriEncode False $ NC.path req, + [ httpMethod, + canonicalUri, canonicalQueryString, canonicalHeaders, signedHeaders, @@ -234,13 +325,13 @@ mkStringToSign ts !scope !canonicalRequest = hashSHA256 canonicalRequest ] -mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString -mkSigningKey ts region !secretKey = +getSigningKey :: SignParams -> ByteString +getSigningKey sp = hmacSHA256RawBS "aws4_request" - . hmacSHA256RawBS "s3" - . hmacSHA256RawBS (encodeUtf8 region) - . hmacSHA256RawBS (awsDateFormatBS ts) - $ B.concat ["AWS4", secretKey] + . hmacSHA256RawBS (toByteString $ spService sp) + . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp) + . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp) + $ 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 = mkSigningKey (spTimeStamp sp) region $ encodeUtf8 $ spSecretKey sp + signingKey = getSigningKey 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 - 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 + + -- compute the updated list of headers to be added for signing purposes. signedContentLength = signedStreamLength payloadLength - streamingHeaders :: [Header] - streamingHeaders = - [ ("x-amz-decoded-content-length", showBS payloadLength), + extraHeaders = + [ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp), + ("x-amz-decoded-content-length", showBS payloadLength), ("content-length", showBS signedContentLength), ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD") ] - headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders - signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign - finalQP = parseQuery (NC.queryString req) + requestHeaders = + addContentEncoding $ + foldr setHeader (NC.requestHeaders req) extraHeaders + -- 1. Compute Seed Signature -- 1.1 Canonical Request - canonicalReq = - mkCanonicalRequest - True + (canonicalReq, signedHeaderKeys) = + getCanonicalRequestAndSignedHeaders + (IsStreamingLength payloadLength) sp - (NC.setQueryString finalQP req) - headersToSign - region = fromMaybe "" $ spRegion sp - scope = mkScope ts region + req + requestHeaders + + 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' diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 06ce443..ae55d48 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/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 - message = T.concat $ r $/ element "Message" &/ content + 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 @@ -269,3 +271,102 @@ parseSelectProgress xmldata = do <$> parseDecimal bScanned <*> parseDecimal bProcessed <*> parseDecimal bReturned + +-- +-- +-- Alice +-- +-- arn:aws:sts::123456789012:assumed-role/demo/TestAR +-- ARO123EXAMPLE123:TestAR +-- +-- +-- ASIAIOSFODNN7EXAMPLE +-- wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY +-- +-- AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW +-- LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd +-- QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU +-- 9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz +-- +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA== +-- +-- 2019-11-09T13:34:41Z +-- +-- 6 +-- +-- +-- c6104cbe-af31-11e0-8154-cbc7ccf896c7 +-- +-- + +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 + } diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 8c93ea1..613caf3 100644 --- a/test/LiveServer.hs +++ b/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"