--
-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
{-# LANGUAGE BangPatterns #-}

module Network.Minio.Sign.V4
  ( SignParams (..),
    signV4QueryParams,
    signV4,
    signV4PostPolicy,
    signV4Stream,
    Service (..),
    credentialScope,
  )
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, 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
import Network.Minio.Errors
import Text.Printf (printf)

-- these headers are not included in the string to sign when signing a
-- request
ignoredHeaders :: Set.HashSet ByteString
ignoredHeaders :: HashSet ByteString
ignoredHeaders =
  forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map
      forall s. CI s -> s
CI.foldedCase
      [ CI ByteString
H.hAuthorization,
        CI ByteString
H.hContentType,
        CI ByteString
H.hUserAgent
      ]

data Service = ServiceS3 | ServiceSTS
  deriving stock (Service -> Service -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Service -> Service -> Bool
$c/= :: Service -> Service -> Bool
== :: Service -> Service -> Bool
$c== :: Service -> Service -> Bool
Eq, Int -> Service -> ShowS
[Service] -> ShowS
Service -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Service] -> ShowS
$cshowList :: [Service] -> ShowS
show :: Service -> String
$cshow :: Service -> String
showsPrec :: Int -> Service -> ShowS
$cshowsPrec :: Int -> Service -> ShowS
Show)

toByteString :: Service -> ByteString
toByteString :: Service -> ByteString
toByteString Service
ServiceS3 = ByteString
"s3"
toByteString Service
ServiceSTS = ByteString
"sts"

data SignParams = SignParams
  { SignParams -> Text
spAccessKey :: Text,
    SignParams -> ScrubbedBytes
spSecretKey :: BA.ScrubbedBytes,
    SignParams -> Maybe ScrubbedBytes
spSessionToken :: Maybe BA.ScrubbedBytes,
    SignParams -> Service
spService :: Service,
    SignParams -> UTCTime
spTimeStamp :: UTCTime,
    SignParams -> Maybe Text
spRegion :: Maybe Text,
    SignParams -> Maybe Int
spExpirySecs :: Maybe UrlExpiry,
    SignParams -> Maybe ByteString
spPayloadHash :: Maybe ByteString
  }
  deriving stock (Int -> SignParams -> ShowS
[SignParams] -> ShowS
SignParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignParams] -> ShowS
$cshowList :: [SignParams] -> ShowS
show :: SignParams -> String
$cshow :: SignParams -> String
showsPrec :: Int -> SignParams -> ShowS
$cshowsPrec :: Int -> SignParams -> ShowS
Show)

mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> Header
mkAuthHeader Text
accessKey ByteString
scope ByteString
signedHeaderKeys ByteString
sign =
  let authValue :: ByteString
authValue =
        [ByteString] -> ByteString
B.concat
          [ ByteString
"AWS4-HMAC-SHA256 Credential=",
            forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
accessKey,
            ByteString
"/",
            ByteString
scope,
            ByteString
", SignedHeaders=",
            ByteString
signedHeaderKeys,
            ByteString
", Signature=",
            ByteString
sign
          ]
   in (CI ByteString
H.hAuthorization, ByteString
authValue)

data IsStreaming = IsStreamingLength Int64 | NotStreaming
  deriving stock (IsStreaming -> IsStreaming -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsStreaming -> IsStreaming -> Bool
$c/= :: IsStreaming -> IsStreaming -> Bool
== :: IsStreaming -> IsStreaming -> Bool
$c== :: IsStreaming -> IsStreaming -> Bool
Eq, Int -> IsStreaming -> ShowS
[IsStreaming] -> ShowS
IsStreaming -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsStreaming] -> ShowS
$cshowList :: [IsStreaming] -> ShowS
show :: IsStreaming -> String
$cshow :: IsStreaming -> String
showsPrec :: Int -> IsStreaming -> ShowS
$cshowsPrec :: Int -> IsStreaming -> ShowS
Show)

amzSecurityToken :: ByteString
amzSecurityToken :: ByteString
amzSecurityToken = ByteString
"X-Amz-Security-Token"

-- | Given SignParams and request details, including request method,
-- request path, headers, query params and payload hash, generates an
-- updated set of headers, including the x-amz-date header and the
-- Authorization header, which includes the signature.
--
-- For normal requests (i.e. without an expiry time), the output is
-- the list of headers to add to authenticate the request.
--
-- If `expiry` is not Nothing, it is assumed that a presigned request
-- 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.
signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery
signV4QueryParams :: SignParams -> Request -> SimpleQuery
signV4QueryParams !SignParams
sp !Request
req =
  let scope :: ByteString
scope = SignParams -> ByteString
credentialScope SignParams
sp
      expiry :: Maybe Int
expiry = SignParams -> Maybe Int
spExpirySecs SignParams
sp

      headersToSign :: SimpleQuery
headersToSign = [Header] -> SimpleQuery
getHeadersToSign forall a b. (a -> b) -> a -> b
$ Request -> [Header]
NC.requestHeaders Request
req
      signedHeaderKeys :: ByteString
signedHeaderKeys = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst SimpleQuery
headersToSign
      -- query-parameters to be added before signing for presigned URLs
      -- (i.e. when `isJust expiry`)
      authQP :: SimpleQuery
authQP =
        [ (ByteString
"X-Amz-Algorithm", ByteString
"AWS4-HMAC-SHA256"),
          (ByteString
"X-Amz-Credential", [ByteString] -> ByteString
B.concat [forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ SignParams -> Text
spAccessKey SignParams
sp, ByteString
"/", ByteString
scope]),
          (ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp),
          (ByteString
"X-Amz-Expires", forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" forall a. Show a => a -> ByteString
showBS Maybe Int
expiry),
          (ByteString
"X-Amz-SignedHeaders", ByteString
signedHeaderKeys)
        ]
          forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)
      finalQP :: [QueryItem]
finalQP =
        ByteString -> [QueryItem]
parseQuery (Request -> ByteString
NC.queryString Request
req)
          forall a. [a] -> [a] -> [a]
++ if forall a. Maybe a -> Bool
isJust Maybe Int
expiry
            then (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a. a -> Maybe a
Just SimpleQuery
authQP
            else []
      -- 1. compute canonical request
      canonicalRequest :: ByteString
canonicalRequest =
        Bool -> SignParams -> Request -> SimpleQuery -> ByteString
mkCanonicalRequest
          Bool
False
          SignParams
sp
          ([QueryItem] -> Request -> Request
NC.setQueryString [QueryItem]
finalQP Request
req)
          SimpleQuery
headersToSign

      -- 2. compute string to sign
      stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign (SignParams -> UTCTime
spTimeStamp SignParams
sp) ByteString
scope ByteString
canonicalRequest
      -- 3.1 compute signing key
      signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
      -- 3.2 compute signature
      signature :: ByteString
signature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
   in (ByteString
"X-Amz-Signature", ByteString
signature) forall a. a -> [a] -> [a]
: SimpleQuery
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 :: SignParams -> Request -> [Header]
signV4 !SignParams
sp !Request
req =
  let scope :: ByteString
scope = SignParams -> ByteString
credentialScope SignParams
sp

      -- extra headers to be added for signing purposes.
      extraHeaders :: [Header]
extraHeaders =
        (CI ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp)
          forall a. a -> [a] -> [a]
: ( -- payload hash is only used for S3 (not STS)
              [ ( CI ByteString
"x-amz-content-sha256",
                  forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp
                )
                | SignParams -> Service
spService SignParams
sp forall a. Eq a => a -> a -> Bool
== Service
ServiceS3
              ]
            )
          forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((forall s. FoldCase s => s -> CI s
mk ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)

      -- 1. compute canonical request
      reqHeaders :: [Header]
reqHeaders = Request -> [Header]
NC.requestHeaders Request
req forall a. [a] -> [a] -> [a]
++ [Header]
extraHeaders
      (ByteString
canonicalRequest, ByteString
signedHeaderKeys) =
        IsStreaming
-> SignParams -> Request -> [Header] -> (ByteString, ByteString)
getCanonicalRequestAndSignedHeaders
          IsStreaming
NotStreaming
          SignParams
sp
          Request
req
          [Header]
reqHeaders

      -- 2. compute string to sign
      stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign (SignParams -> UTCTime
spTimeStamp SignParams
sp) ByteString
scope ByteString
canonicalRequest
      -- 3.1 compute signing key
      signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
      -- 3.2 compute signature
      signature :: ByteString
signature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
      -- 4. compute auth header
      authHeader :: Header
authHeader = Text -> ByteString -> ByteString -> ByteString -> Header
mkAuthHeader (SignParams -> Text
spAccessKey SignParams
sp) ByteString
scope ByteString
signedHeaderKeys ByteString
signature
   in Header
authHeader forall a. a -> [a] -> [a]
: [Header]
extraHeaders

credentialScope :: SignParams -> ByteString
credentialScope :: SignParams -> ByteString
credentialScope SignParams
sp =
  let region :: Text
region = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe Text
spRegion SignParams
sp
   in ByteString -> [ByteString] -> ByteString
B.intercalate
        ByteString
"/"
        [ forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"%Y%m%d" forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp,
          forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
region,
          Service -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$ SignParams -> Service
spService SignParams
sp,
          ByteString
"aws4_request"
        ]

-- Folds header name, trims whitespace in header values, skips ignored headers
-- and sorts headers.
getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
getHeadersToSign :: [Header] -> SimpleQuery
getHeadersToSign ![Header]
h =
  forall a. (a -> Bool) -> [a] -> [a]
filter ((\ByteString
hdr -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member ByteString
hdr HashSet ByteString
ignoredHeaders) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall s. CI s -> s
CI.foldedCase ByteString -> ByteString
stripBS) [Header]
h

-- | Given the list of headers in the request, computes the canonical headers
-- and the signed headers strings.
getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)
getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)
getCanonicalHeaders NonEmpty Header
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 :: SimpleQuery
headersToSign =
        forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$
          forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (\(ByteString, ByteString)
a (ByteString, ByteString)
b -> forall a. Ord a => a -> a -> Ordering
compare (forall a b. (a, b) -> a
fst (ByteString, ByteString)
a) (forall a b. (a, b) -> a
fst (ByteString, ByteString)
b)) forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$
              forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter ((\ByteString
hdr -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member ByteString
hdr HashSet ByteString
ignoredHeaders) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
                forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall s. CI s -> s
CI.foldedCase ByteString -> ByteString
stripBS) NonEmpty Header
h

      canonicalHeaders :: ByteString
canonicalHeaders = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
a, ByteString
b) -> ByteString
a forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> ByteString
b forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") SimpleQuery
headersToSign
      signedHeaderKeys :: ByteString
signedHeaderKeys = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst SimpleQuery
headersToSign
   in (ByteString
canonicalHeaders, ByteString
signedHeaderKeys)

getCanonicalRequestAndSignedHeaders ::
  IsStreaming ->
  SignParams ->
  NC.Request ->
  [Header] ->
  (ByteString, ByteString)
getCanonicalRequestAndSignedHeaders :: IsStreaming
-> SignParams -> Request -> [Header] -> (ByteString, ByteString)
getCanonicalRequestAndSignedHeaders IsStreaming
isStreaming SignParams
sp Request
req [Header]
requestHeaders =
  let httpMethod :: ByteString
httpMethod = Request -> ByteString
NC.method Request
req

      canonicalUri :: ByteString
canonicalUri = forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
False forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.path Request
req

      canonicalQueryString :: ByteString
canonicalQueryString =
        ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"&" forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
"=", ByteString
y]) forall a b. (a -> b) -> a -> b
$
            forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$
              forall a b. (a -> b) -> [a] -> [b]
map
                ( forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True))
                )
                (ByteString -> [QueryItem]
parseQuery forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.queryString Request
req)

      (ByteString
canonicalHeaders, ByteString
signedHeaderKeys) = NonEmpty Header -> (ByteString, ByteString)
getCanonicalHeaders forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [Header]
requestHeaders
      payloadHashStr :: ByteString
payloadHashStr =
        case IsStreaming
isStreaming of
          IsStreamingLength Int64
_ -> ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
          IsStreaming
NotStreaming -> forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp

      canonicalRequest :: ByteString
canonicalRequest =
        ByteString -> [ByteString] -> ByteString
B.intercalate
          ByteString
"\n"
          [ ByteString
httpMethod,
            ByteString
canonicalUri,
            ByteString
canonicalQueryString,
            ByteString
canonicalHeaders,
            ByteString
signedHeaderKeys,
            ByteString
payloadHashStr
          ]
   in (ByteString
canonicalRequest, ByteString
signedHeaderKeys)

mkCanonicalRequest ::
  Bool ->
  SignParams ->
  NC.Request ->
  [(ByteString, ByteString)] ->
  ByteString
mkCanonicalRequest :: Bool -> SignParams -> Request -> SimpleQuery -> ByteString
mkCanonicalRequest !Bool
isStreaming !SignParams
sp !Request
req !SimpleQuery
headersForSign =
  let httpMethod :: ByteString
httpMethod = Request -> ByteString
NC.method Request
req
      canonicalUri :: ByteString
canonicalUri = forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
False forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.path Request
req
      canonicalQueryString :: ByteString
canonicalQueryString =
        ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"&" forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
"=", ByteString
y]) forall a b. (a -> b) -> a -> b
$
            forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(ByteString, ByteString)
a (ByteString, ByteString)
b -> forall a. Ord a => a -> a -> Ordering
compare (forall a b. (a, b) -> a
fst (ByteString, ByteString)
a) (forall a b. (a, b) -> a
fst (ByteString, ByteString)
b)) forall a b. (a -> b) -> a -> b
$
              forall a b. (a -> b) -> [a] -> [b]
map
                ( forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (forall s. UriEncodable s => Bool -> s -> ByteString
uriEncode Bool
True))
                )
                (ByteString -> [QueryItem]
parseQuery forall a b. (a -> b) -> a -> b
$ Request -> ByteString
NC.queryString Request
req)
      sortedHeaders :: SimpleQuery
sortedHeaders = forall a. Ord a => [a] -> [a]
sort SimpleQuery
headersForSign
      canonicalHeaders :: ByteString
canonicalHeaders =
        [ByteString] -> ByteString
B.concat forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> [ByteString] -> ByteString
B.concat [ByteString
x, ByteString
":", ByteString
y, ByteString
"\n"]) SimpleQuery
sortedHeaders
      signedHeaders :: ByteString
signedHeaders = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst SimpleQuery
sortedHeaders
      payloadHashStr :: ByteString
payloadHashStr =
        if Bool
isStreaming
          then ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
          else forall a. a -> Maybe a -> a
fromMaybe ByteString
"UNSIGNED-PAYLOAD" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe ByteString
spPayloadHash SignParams
sp
   in ByteString -> [ByteString] -> ByteString
B.intercalate
        ByteString
"\n"
        [ ByteString
httpMethod,
          ByteString
canonicalUri,
          ByteString
canonicalQueryString,
          ByteString
canonicalHeaders,
          ByteString
signedHeaders,
          ByteString
payloadHashStr
        ]

mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign UTCTime
ts !ByteString
scope !ByteString
canonicalRequest =
  ByteString -> [ByteString] -> ByteString
B.intercalate
    ByteString
"\n"
    [ ByteString
"AWS4-HMAC-SHA256",
      UTCTime -> ByteString
awsTimeFormatBS UTCTime
ts,
      ByteString
scope,
      ByteString -> ByteString
hashSHA256 ByteString
canonicalRequest
    ]

getSigningKey :: SignParams -> ByteString
getSigningKey :: SignParams -> ByteString
getSigningKey SignParams
sp =
  ByteString -> ByteString -> ByteString
hmacSHA256RawBS ByteString
"aws4_request"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (Service -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$ SignParams -> Service
spService SignParams
sp)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ SignParams -> Maybe Text
spRegion SignParams
sp)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
hmacSHA256RawBS (UTCTime -> ByteString
awsDateFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp)
    forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
"AWS4", forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall a b. (a -> b) -> a -> b
$ SignParams -> ScrubbedBytes
spSecretKey SignParams
sp]

computeSignature :: ByteString -> ByteString -> ByteString
computeSignature :: ByteString -> ByteString -> ByteString
computeSignature !ByteString
toSign !ByteString
key = forall a. ByteArrayAccess a => a -> ByteString
digestToBase16 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HMAC SHA256
hmacSHA256 ByteString
toSign ByteString
key

-- | Takes a validated Post Policy JSON bytestring, the signing time,
-- and ConnInfo and returns form-data for the POST upload containing
-- just the signature and the encoded post-policy.
signV4PostPolicy ::
  ByteString ->
  SignParams ->
  Map.HashMap Text ByteString
signV4PostPolicy :: ByteString -> SignParams -> HashMap Text ByteString
signV4PostPolicy !ByteString
postPolicyJSON !SignParams
sp =
  let stringToSign :: ByteString
stringToSign = ByteString -> ByteString
Base64.encode ByteString
postPolicyJSON
      signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
      signature :: ByteString
signature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
   in forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$
        [ (Text
"x-amz-signature", ByteString
signature),
          (Text
"policy", ByteString
stringToSign)
        ]
          forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)

chunkSizeConstant :: Int
chunkSizeConstant :: Int
chunkSizeConstant = Int
64 forall a. Num a => a -> a -> a
* Int
1024

-- base16Len computes the number of bytes required to represent @n (> 0)@ in
-- hexadecimal.
base16Len :: (Integral a) => a -> Int
base16Len :: forall a. Integral a => a -> Int
base16Len a
n
  | a
n forall a. Eq a => a -> a -> Bool
== a
0 = Int
0
  | Bool
otherwise = Int
1 forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> Int
base16Len (a
n forall a. Integral a => a -> a -> a
`div` a
16)

signedStreamLength :: Int64 -> Int64
signedStreamLength :: Int64 -> Int64
signedStreamLength Int64
dataLen =
  let chunkSzInt :: Int64
chunkSzInt = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chunkSizeConstant
      (Int64
numChunks, Int64
lastChunkLen) = forall a. Integral a => a -> a -> (a, a)
quotRem Int64
dataLen Int64
chunkSzInt
      -- Structure of a chunk:
      --   string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n
      encodedChunkLen :: a -> a
encodedChunkLen a
csz = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Integral a => a -> Int
base16Len a
csz) forall a. Num a => a -> a -> a
+ a
17 forall a. Num a => a -> a -> a
+ a
64 forall a. Num a => a -> a -> a
+ a
2 forall a. Num a => a -> a -> a
+ a
csz forall a. Num a => a -> a -> a
+ a
2
      fullChunkSize :: Int64
fullChunkSize = forall {a}. Integral a => a -> a
encodedChunkLen Int64
chunkSzInt
      lastChunkSize :: Int64
lastChunkSize = forall a. a -> a -> Bool -> a
bool Int64
0 (forall {a}. Integral a => a -> a
encodedChunkLen Int64
lastChunkLen) forall a b. (a -> b) -> a -> b
$ Int64
lastChunkLen forall a. Ord a => a -> a -> Bool
> Int64
0
      finalChunkSize :: Int64
finalChunkSize = Int64
1 forall a. Num a => a -> a -> a
+ Int64
17 forall a. Num a => a -> a -> a
+ Int64
64 forall a. Num a => a -> a -> a
+ Int64
2 forall a. Num a => a -> a -> a
+ Int64
2
   in Int64
numChunks forall a. Num a => a -> a -> a
* Int64
fullChunkSize forall a. Num a => a -> a -> a
+ Int64
lastChunkSize forall a. Num a => a -> a -> a
+ Int64
finalChunkSize

-- For streaming S3, we need to update the content-encoding header.
addContentEncoding :: [Header] -> [Header]
addContentEncoding :: [Header] -> [Header]
addContentEncoding [Header]
hs =
  -- assume there is at most one content-encoding header.
  let ([Header]
ceHdrs, [Header]
others) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== CI ByteString
hContentEncoding) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [Header]
hs
   in forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (CI ByteString
hContentEncoding, ByteString
"aws-chunked")
        (\(CI ByteString
k, ByteString
v) -> (CI ByteString
k, ByteString
v forall a. Semigroup a => a -> a -> a
<> ByteString
",aws-chunked"))
        (forall a. [a] -> Maybe a
listToMaybe [Header]
ceHdrs)
        forall a. a -> [a] -> [a]
: [Header]
others

signV4Stream ::
  Int64 ->
  SignParams ->
  NC.Request ->
  (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
signV4Stream :: Int64
-> SignParams
-> Request
-> ConduitT () ByteString (ResourceT IO) ()
-> Request
signV4Stream !Int64
payloadLength !SignParams
sp !Request
req =
  let ts :: UTCTime
ts = SignParams -> UTCTime
spTimeStamp SignParams
sp

      -- compute the updated list of headers to be added for signing purposes.
      signedContentLength :: Int64
signedContentLength = Int64 -> Int64
signedStreamLength Int64
payloadLength
      extraHeaders :: [Header]
extraHeaders =
        [ (CI ByteString
"X-Amz-Date", UTCTime -> ByteString
awsTimeFormatBS forall a b. (a -> b) -> a -> b
$ SignParams -> UTCTime
spTimeStamp SignParams
sp),
          (CI ByteString
"x-amz-decoded-content-length", forall a. Show a => a -> ByteString
showBS Int64
payloadLength),
          (CI ByteString
"content-length", forall a. Show a => a -> ByteString
showBS Int64
signedContentLength),
          (CI ByteString
"x-amz-content-sha256", ByteString
"STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
        ]
          forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ((forall s. FoldCase s => s -> CI s
mk ByteString
amzSecurityToken,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignParams -> Maybe ScrubbedBytes
spSessionToken SignParams
sp)
      requestHeaders :: [Header]
requestHeaders =
        [Header] -> [Header]
addContentEncoding forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Header -> [Header] -> [Header]
setHeader (Request -> [Header]
NC.requestHeaders Request
req) [Header]
extraHeaders

      -- 1. Compute Seed Signature
      -- 1.1 Canonical Request
      (ByteString
canonicalReq, ByteString
signedHeaderKeys) =
        IsStreaming
-> SignParams -> Request -> [Header] -> (ByteString, ByteString)
getCanonicalRequestAndSignedHeaders
          (Int64 -> IsStreaming
IsStreamingLength Int64
payloadLength)
          SignParams
sp
          Request
req
          [Header]
requestHeaders

      scope :: ByteString
scope = SignParams -> ByteString
credentialScope SignParams
sp
      accessKey :: Text
accessKey = SignParams -> Text
spAccessKey SignParams
sp
      -- 1.2 String toSign
      stringToSign :: ByteString
stringToSign = UTCTime -> ByteString -> ByteString -> ByteString
mkStringToSign UTCTime
ts ByteString
scope ByteString
canonicalReq
      -- 1.3 Compute signature
      -- 1.3.1 compute signing key
      signingKey :: ByteString
signingKey = SignParams -> ByteString
getSigningKey SignParams
sp
      -- 1.3.2 Compute signature
      seedSignature :: ByteString
seedSignature = ByteString -> ByteString -> ByteString
computeSignature ByteString
stringToSign ByteString
signingKey
      -- 1.3.3 Compute Auth Header
      authHeader :: Header
authHeader = Text -> ByteString -> ByteString -> ByteString -> Header
mkAuthHeader Text
accessKey ByteString
scope ByteString
signedHeaderKeys ByteString
seedSignature
      -- 1.4 Updated headers for the request
      finalReqHeaders :: [Header]
finalReqHeaders = Header
authHeader forall a. a -> [a] -> [a]
: [Header]
requestHeaders
      -- headersToAdd = authHeader : datePair : streamingHeaders

      toHexStr :: t -> ByteString
toHexStr t
n = String -> ByteString
B8.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%x" t
n
      (Int64
numParts, Int64
lastPSize) = Int64
payloadLength forall a. Integral a => a -> a -> (a, a)
`quotRem` forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chunkSizeConstant
      -- Function to compute string to sign for each chunk.
      chunkStrToSign :: ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign ByteString
currChunkHash =
        ByteString -> [ByteString] -> ByteString
B.intercalate
          ByteString
"\n"
          [ ByteString
"AWS4-HMAC-SHA256-PAYLOAD",
            UTCTime -> ByteString
awsTimeFormatBS UTCTime
ts,
            ByteString
scope,
            ByteString
prevSign,
            ByteString -> ByteString
hashSHA256 ByteString
"",
            ByteString
currChunkHash
          ]
      -- Read n byte from upstream and return a strict bytestring.
      mustTakeN :: Int -> ConduitT ByteString c m ByteString
mustTakeN Int
n = do
        ByteString
bs <- ByteString -> ByteString
LB.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
C.takeCE Int
n forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
C.sinkLazy)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
bs forall a. Eq a => a -> a -> Bool
/= Int
n) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO MErrV
MErrVStreamingBodyUnexpectedEOF
        forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
      signerConduit :: t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit t
n a
lps ByteString
prevSign =
        -- First case encodes a full chunk of length
        -- 'chunkSizeConstant'.
        if
            | t
n forall a. Ord a => a -> a -> Bool
> t
0 -> do
                ByteString
bs <- forall {m :: * -> *} {c}.
MonadIO m =>
Int -> ConduitT ByteString c m ByteString
mustTakeN Int
chunkSizeConstant
                let strToSign :: ByteString
strToSign = ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign (ByteString -> ByteString
hashSHA256 ByteString
bs)
                    nextSign :: ByteString
nextSign = ByteString -> ByteString -> ByteString
computeSignature ByteString
strToSign ByteString
signingKey
                    chunkBS :: ByteString
chunkBS =
                      forall {t}. PrintfArg t => t -> ByteString
toHexStr Int
chunkSizeConstant
                        forall a. Semigroup a => a -> a -> a
<> ByteString
";chunk-signature="
                        forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign
                        forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
                        forall a. Semigroup a => a -> a -> a
<> ByteString
bs
                        forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
                forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
chunkBS
                t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit (t
n forall a. Num a => a -> a -> a
- t
1) a
lps ByteString
nextSign

            -- Second case encodes the last chunk which is smaller than
            -- 'chunkSizeConstant'
            | a
lps forall a. Ord a => a -> a -> Bool
> a
0 -> do
                ByteString
bs <- forall {m :: * -> *} {c}.
MonadIO m =>
Int -> ConduitT ByteString c m ByteString
mustTakeN forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
lps
                let strToSign :: ByteString
strToSign = ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign (ByteString -> ByteString
hashSHA256 ByteString
bs)
                    nextSign :: ByteString
nextSign = ByteString -> ByteString -> ByteString
computeSignature ByteString
strToSign ByteString
signingKey
                    chunkBS :: ByteString
chunkBS =
                      forall {t}. PrintfArg t => t -> ByteString
toHexStr a
lps
                        forall a. Semigroup a => a -> a -> a
<> ByteString
";chunk-signature="
                        forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign
                        forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
                        forall a. Semigroup a => a -> a -> a
<> ByteString
bs
                        forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
                forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
chunkBS
                t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit t
0 a
0 ByteString
nextSign

            -- Last case encodes the final signature chunk that has no
            -- data.
            | Bool
otherwise -> do
                let strToSign :: ByteString
strToSign = ByteString -> ByteString -> ByteString
chunkStrToSign ByteString
prevSign (ByteString -> ByteString
hashSHA256 ByteString
"")
                    nextSign :: ByteString
nextSign = ByteString -> ByteString -> ByteString
computeSignature ByteString
strToSign ByteString
signingKey
                    lastChunkBS :: ByteString
lastChunkBS = ByteString
"0;chunk-signature=" forall a. Semigroup a => a -> a -> a
<> ByteString
nextSign forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n\r\n"
                forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
lastChunkBS
   in \ConduitT () ByteString (ResourceT IO) ()
src ->
        Request
req
          { requestHeaders :: [Header]
NC.requestHeaders = [Header]
finalReqHeaders,
            requestBody :: RequestBody
NC.requestBody =
              Int64 -> ConduitT () ByteString (ResourceT IO) () -> RequestBody
NC.requestBodySource Int64
signedContentLength forall a b. (a -> b) -> a -> b
$
                ConduitT () ByteString (ResourceT IO) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall {m :: * -> *} {t} {a}.
(MonadIO m, Ord t, Num t, Integral a, PrintfArg a) =>
t -> a -> ByteString -> ConduitT ByteString ByteString m ()
signerConduit Int64
numParts Int64
lastPSize ByteString
seedSignature
          }

-- "setHeader r hdr" adds the hdr to r, replacing it in r if it already exists.
setHeader :: Header -> RequestHeaders -> RequestHeaders
setHeader :: Header -> [Header] -> [Header]
setHeader Header
hdr [Header]
r =
  let r' :: [Header]
r' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(CI ByteString
name, ByteString
_) -> CI ByteString
name forall a. Eq a => a -> a -> Bool
/= forall a b. (a, b) -> a
fst Header
hdr) [Header]
r
   in Header
hdr forall a. a -> [a] -> [a]
: [Header]
r'