-- |
-- Module      : Amazonka.Sign.V4.Base
-- Copyright   : (c) 2013-2021 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Amazonka.Sign.V4.Base where

import qualified Amazonka.Bytes as Bytes
import qualified Amazonka.Crypto as Crypto
import Amazonka.Data hiding (Path)
import Amazonka.Lens ((%~), (<>~), (^.))
import Amazonka.Prelude
import Amazonka.Request
import Amazonka.Types
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Foldable
import qualified Data.Function as Function
import qualified Data.List as List
import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Types as HTTP

data V4 = V4
  { V4 -> UTCTime
metaTime :: UTCTime,
    V4 -> Method
metaMethod :: Method,
    V4 -> Path
metaPath :: Path,
    V4 -> Endpoint
metaEndpoint :: Endpoint,
    V4 -> Credential
metaCredential :: Credential,
    V4 -> CanonicalQuery
metaCanonicalQuery :: CanonicalQuery,
    V4 -> CanonicalRequest
metaCanonicalRequest :: CanonicalRequest,
    V4 -> CanonicalHeaders
metaCanonicalHeaders :: CanonicalHeaders,
    V4 -> SignedHeaders
metaSignedHeaders :: SignedHeaders,
    V4 -> StringToSign
metaStringToSign :: StringToSign,
    V4 -> Signature
metaSignature :: Signature,
    V4 -> [Header]
metaHeaders :: [Header],
    V4 -> Maybe Seconds
metaTimeout :: (Maybe Seconds)
  }

instance ToLog V4 where
  build :: V4 -> ByteStringBuilder
build V4 {[Header]
Maybe Seconds
UTCTime
Endpoint
CanonicalHeaders
CanonicalQuery
CanonicalRequest
Credential
Method
Path
Signature
SignedHeaders
StringToSign
metaTimeout :: Maybe Seconds
metaHeaders :: [Header]
metaSignature :: Signature
metaStringToSign :: StringToSign
metaSignedHeaders :: SignedHeaders
metaCanonicalHeaders :: CanonicalHeaders
metaCanonicalRequest :: CanonicalRequest
metaCanonicalQuery :: CanonicalQuery
metaCredential :: Credential
metaEndpoint :: Endpoint
metaPath :: Path
metaMethod :: Method
metaTime :: UTCTime
$sel:metaTimeout:V4 :: V4 -> Maybe Seconds
$sel:metaHeaders:V4 :: V4 -> [Header]
$sel:metaSignature:V4 :: V4 -> Signature
$sel:metaStringToSign:V4 :: V4 -> StringToSign
$sel:metaSignedHeaders:V4 :: V4 -> SignedHeaders
$sel:metaCanonicalHeaders:V4 :: V4 -> CanonicalHeaders
$sel:metaCanonicalRequest:V4 :: V4 -> CanonicalRequest
$sel:metaCanonicalQuery:V4 :: V4 -> CanonicalQuery
$sel:metaCredential:V4 :: V4 -> Credential
$sel:metaEndpoint:V4 :: V4 -> Endpoint
$sel:metaPath:V4 :: V4 -> Path
$sel:metaMethod:V4 :: V4 -> Method
$sel:metaTime:V4 :: V4 -> UTCTime
..} =
    [ByteStringBuilder] -> ByteStringBuilder
buildLines
      [ ByteStringBuilder
"[Version 4 Metadata] {",
        ByteStringBuilder
"  time              = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> UTCTime -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build UTCTime
metaTime,
        ByteStringBuilder
"  endpoint          = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build (Endpoint -> ByteString
_endpointHost Endpoint
metaEndpoint),
        ByteStringBuilder
"  credential        = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> Credential -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build Credential
metaCredential,
        ByteStringBuilder
"  signed headers    = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> SignedHeaders -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build SignedHeaders
metaSignedHeaders,
        ByteStringBuilder
"  signature         = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> Signature -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build Signature
metaSignature,
        ByteStringBuilder
"  string to sign    = {",
        StringToSign -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build StringToSign
metaStringToSign,
        ByteStringBuilder
"}",
        ByteStringBuilder
"  canonical request = {",
        CanonicalRequest -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build CanonicalRequest
metaCanonicalRequest,
        ByteStringBuilder
"  }",
        ByteStringBuilder
"}"
      ]

base ::
  Hash ->
  Request a ->
  AuthEnv ->
  Region ->
  UTCTime ->
  (V4, ClientRequest -> ClientRequest)
base :: Hash
-> Request a
-> AuthEnv
-> Region
-> UTCTime
-> (V4, ClientRequest -> ClientRequest)
base Hash
h Request a
rq AuthEnv
a Region
r UTCTime
ts = (V4
meta, ClientRequest -> ClientRequest
auth)
  where
    auth :: ClientRequest -> ClientRequest
auth = ([Header] -> Identity [Header])
-> ClientRequest -> Identity ClientRequest
Lens' ClientRequest [Header]
clientRequestHeaders (([Header] -> Identity [Header])
 -> ClientRequest -> Identity ClientRequest)
-> [Header] -> ClientRequest -> ClientRequest
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [(HeaderName
HTTP.hAuthorization, V4 -> ByteString
authorisation V4
meta)]

    meta :: V4
meta = AuthEnv
-> Region
-> UTCTime
-> (Credential -> SignedHeaders -> QueryString -> QueryString)
-> Hash
-> Request a
-> V4
forall a.
AuthEnv
-> Region
-> UTCTime
-> (Credential -> SignedHeaders -> QueryString -> QueryString)
-> Hash
-> Request a
-> V4
signMetadata AuthEnv
a Region
r UTCTime
ts Credential -> SignedHeaders -> QueryString -> QueryString
forall p p a. p -> p -> a -> a
presigner Hash
h (Request a -> Request a
prepare Request a
rq)

    presigner :: p -> p -> a -> a
presigner p
_ p
_ = a -> a
forall a. a -> a
id

    prepare :: Request a -> Request a
prepare =
      ([Header] -> Identity [Header])
-> Request a -> Identity (Request a)
forall a. Lens' (Request a) [Header]
requestHeaders
        (([Header] -> Identity [Header])
 -> Request a -> Identity (Request a))
-> ([Header] -> [Header]) -> Request a -> Request a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( HeaderName -> ByteString -> [Header] -> [Header]
hdr HeaderName
hHost ByteString
host
               ([Header] -> [Header])
-> ([Header] -> [Header]) -> [Header] -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString -> [Header] -> [Header]
hdr HeaderName
hAMZDate (AWSTime -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (UTCTime -> AWSTime
forall (a :: Format). UTCTime -> Time a
Time UTCTime
ts :: AWSTime))
               ([Header] -> [Header])
-> ([Header] -> [Header]) -> [Header] -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString -> [Header] -> [Header]
hdr HeaderName
hAMZContentSHA256 (Hash -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Hash
h)
               ([Header] -> [Header])
-> ([Header] -> [Header]) -> [Header] -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Header] -> [Header])
-> (Sensitive SessionToken -> [Header] -> [Header])
-> Maybe (Sensitive SessionToken)
-> [Header]
-> [Header]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Header] -> [Header]
forall a. a -> a
id (HeaderName -> ByteString -> [Header] -> [Header]
hdr HeaderName
hAMZToken (ByteString -> [Header] -> [Header])
-> (Sensitive SessionToken -> ByteString)
-> Sensitive SessionToken
-> [Header]
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sensitive SessionToken -> ByteString
forall a. ToByteString a => a -> ByteString
toBS) (AuthEnv -> Maybe (Sensitive SessionToken)
_authSessionToken AuthEnv
a)
           )

    host :: ByteString
host =
      case (Endpoint -> Bool
_endpointSecure Endpoint
end, Endpoint -> Int
_endpointPort Endpoint
end) of
        (Bool
False, Int
80) -> Endpoint -> ByteString
_endpointHost Endpoint
end
        (Bool
True, Int
443) -> Endpoint -> ByteString
_endpointHost Endpoint
end
        (Bool
_, Int
port) -> Endpoint -> ByteString
_endpointHost Endpoint
end ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Int
port

    end :: Endpoint
end = Service -> Region -> Endpoint
_serviceEndpoint (Request a -> Service
forall a. Request a -> Service
_requestService Request a
rq) Region
r

-- | Used to tag provenance. This allows keeping the same layout as
-- the signing documentation, passing 'ByteString's everywhere, with
-- some type guarantees.
--
-- Data.Tagged is not used for no reason other than the dependency, syntactic length,
-- and the ToByteString instance.
newtype Tag (s :: Symbol) a = Tag {Tag s a -> a
untag :: a}
  deriving stock (Int -> Tag s a -> ShowS
[Tag s a] -> ShowS
Tag s a -> String
(Int -> Tag s a -> ShowS)
-> (Tag s a -> String) -> ([Tag s a] -> ShowS) -> Show (Tag s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Symbol) a. Show a => Int -> Tag s a -> ShowS
forall (s :: Symbol) a. Show a => [Tag s a] -> ShowS
forall (s :: Symbol) a. Show a => Tag s a -> String
showList :: [Tag s a] -> ShowS
$cshowList :: forall (s :: Symbol) a. Show a => [Tag s a] -> ShowS
show :: Tag s a -> String
$cshow :: forall (s :: Symbol) a. Show a => Tag s a -> String
showsPrec :: Int -> Tag s a -> ShowS
$cshowsPrec :: forall (s :: Symbol) a. Show a => Int -> Tag s a -> ShowS
Show)

instance ToByteString (Tag s ByteString) where toBS :: Tag s ByteString -> ByteString
toBS = Tag s ByteString -> ByteString
forall (s :: Symbol) a. Tag s a -> a
untag

instance ToLog (Tag s ByteString) where build :: Tag s ByteString -> ByteStringBuilder
build = ByteString -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build (ByteString -> ByteStringBuilder)
-> (Tag s ByteString -> ByteString)
-> Tag s ByteString
-> ByteStringBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag s ByteString -> ByteString
forall (s :: Symbol) a. Tag s a -> a
untag

instance ToByteString CredentialScope where
  toBS :: CredentialScope -> ByteString
toBS = ByteString -> [ByteString] -> ByteString
BS8.intercalate ByteString
"/" ([ByteString] -> ByteString)
-> (CredentialScope -> [ByteString])
-> CredentialScope
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CredentialScope -> [ByteString]
forall (s :: Symbol) a. Tag s a -> a
untag

type Hash = Tag "body-digest" ByteString

type StringToSign = Tag "string-to-sign" ByteString

type Credential = Tag "credential" ByteString

type CredentialScope = Tag "credential-scope" [ByteString]

type CanonicalRequest = Tag "canonical-request" ByteString

type CanonicalHeaders = Tag "canonical-headers" ByteString

type CanonicalQuery = Tag "canonical-query" ByteString

type SignedHeaders = Tag "signed-headers" ByteString

type NormalisedHeaders = Tag "normalised-headers" [(ByteString, ByteString)]

type Method = Tag "method" ByteString

type Path = Tag "path" ByteString

type Signature = Tag "signature" ByteString

authorisation :: V4 -> ByteString
authorisation :: V4 -> ByteString
authorisation V4 {[Header]
Maybe Seconds
UTCTime
Endpoint
CanonicalHeaders
CanonicalQuery
CanonicalRequest
Credential
Method
Path
Signature
SignedHeaders
StringToSign
metaTimeout :: Maybe Seconds
metaHeaders :: [Header]
metaSignature :: Signature
metaStringToSign :: StringToSign
metaSignedHeaders :: SignedHeaders
metaCanonicalHeaders :: CanonicalHeaders
metaCanonicalRequest :: CanonicalRequest
metaCanonicalQuery :: CanonicalQuery
metaCredential :: Credential
metaEndpoint :: Endpoint
metaPath :: Path
metaMethod :: Method
metaTime :: UTCTime
$sel:metaTimeout:V4 :: V4 -> Maybe Seconds
$sel:metaHeaders:V4 :: V4 -> [Header]
$sel:metaSignature:V4 :: V4 -> Signature
$sel:metaStringToSign:V4 :: V4 -> StringToSign
$sel:metaSignedHeaders:V4 :: V4 -> SignedHeaders
$sel:metaCanonicalHeaders:V4 :: V4 -> CanonicalHeaders
$sel:metaCanonicalRequest:V4 :: V4 -> CanonicalRequest
$sel:metaCanonicalQuery:V4 :: V4 -> CanonicalQuery
$sel:metaCredential:V4 :: V4 -> Credential
$sel:metaEndpoint:V4 :: V4 -> Endpoint
$sel:metaPath:V4 :: V4 -> Path
$sel:metaMethod:V4 :: V4 -> Method
$sel:metaTime:V4 :: V4 -> UTCTime
..} =
  ByteString
algorithm
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" Credential="
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Credential -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Credential
metaCredential
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
", SignedHeaders="
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> SignedHeaders -> ByteString
forall a. ToByteString a => a -> ByteString
toBS SignedHeaders
metaSignedHeaders
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
", Signature="
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Signature -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Signature
metaSignature

signRequest ::
  -- | Pre-signRequestd signing metadata.
  V4 ->
  -- | The request body.
  Client.RequestBody ->
  -- | Insert authentication information.
  (ClientRequest -> ClientRequest) ->
  Signed a
signRequest :: V4 -> RequestBody -> (ClientRequest -> ClientRequest) -> Signed a
signRequest m :: V4
m@V4 {[Header]
Maybe Seconds
UTCTime
Endpoint
CanonicalHeaders
CanonicalQuery
CanonicalRequest
Credential
Method
Path
Signature
SignedHeaders
StringToSign
metaTimeout :: Maybe Seconds
metaHeaders :: [Header]
metaSignature :: Signature
metaStringToSign :: StringToSign
metaSignedHeaders :: SignedHeaders
metaCanonicalHeaders :: CanonicalHeaders
metaCanonicalRequest :: CanonicalRequest
metaCanonicalQuery :: CanonicalQuery
metaCredential :: Credential
metaEndpoint :: Endpoint
metaPath :: Path
metaMethod :: Method
metaTime :: UTCTime
$sel:metaTimeout:V4 :: V4 -> Maybe Seconds
$sel:metaHeaders:V4 :: V4 -> [Header]
$sel:metaSignature:V4 :: V4 -> Signature
$sel:metaStringToSign:V4 :: V4 -> StringToSign
$sel:metaSignedHeaders:V4 :: V4 -> SignedHeaders
$sel:metaCanonicalHeaders:V4 :: V4 -> CanonicalHeaders
$sel:metaCanonicalRequest:V4 :: V4 -> CanonicalRequest
$sel:metaCanonicalQuery:V4 :: V4 -> CanonicalQuery
$sel:metaCredential:V4 :: V4 -> Credential
$sel:metaEndpoint:V4 :: V4 -> Endpoint
$sel:metaPath:V4 :: V4 -> Path
$sel:metaMethod:V4 :: V4 -> Method
$sel:metaTime:V4 :: V4 -> UTCTime
..} RequestBody
b ClientRequest -> ClientRequest
auth = Meta -> ClientRequest -> Signed a
forall a. Meta -> ClientRequest -> Signed a
Signed (V4 -> Meta
forall a. ToLog a => a -> Meta
Meta V4
m) (ClientRequest -> ClientRequest
auth ClientRequest
rq)
  where
    rq :: ClientRequest
rq =
      (Endpoint -> Maybe Seconds -> ClientRequest
newClientRequest Endpoint
metaEndpoint Maybe Seconds
metaTimeout)
        { method :: ByteString
Client.method = Method -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Method
metaMethod,
          path :: ByteString
Client.path = Path -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Path
metaPath,
          queryString :: ByteString
Client.queryString = ByteString
qry,
          requestHeaders :: [Header]
Client.requestHeaders = [Header]
metaHeaders,
          requestBody :: RequestBody
Client.requestBody = RequestBody
b
        }

    qry :: ByteString
qry
      | ByteString -> Bool
BS.null ByteString
x = ByteString
x
      | Bool
otherwise = Char
'?' Char -> ByteString -> ByteString
`BS8.cons` ByteString
x
      where
        x :: ByteString
x = CanonicalQuery -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CanonicalQuery
metaCanonicalQuery

signMetadata ::
  AuthEnv ->
  Region ->
  UTCTime ->
  (Credential -> SignedHeaders -> QueryString -> QueryString) ->
  Hash ->
  Request a ->
  V4
signMetadata :: AuthEnv
-> Region
-> UTCTime
-> (Credential -> SignedHeaders -> QueryString -> QueryString)
-> Hash
-> Request a
-> V4
signMetadata AuthEnv
a Region
r UTCTime
ts Credential -> SignedHeaders -> QueryString -> QueryString
presign Hash
digest Request a
rq =
  V4 :: UTCTime
-> Method
-> Path
-> Endpoint
-> Credential
-> CanonicalQuery
-> CanonicalRequest
-> CanonicalHeaders
-> SignedHeaders
-> StringToSign
-> Signature
-> [Header]
-> Maybe Seconds
-> V4
V4
    { $sel:metaTime:V4 :: UTCTime
metaTime = UTCTime
ts,
      $sel:metaMethod:V4 :: Method
metaMethod = Method
method,
      $sel:metaPath:V4 :: Path
metaPath = Path
path,
      $sel:metaEndpoint:V4 :: Endpoint
metaEndpoint = Endpoint
end,
      $sel:metaCredential:V4 :: Credential
metaCredential = Credential
cred,
      $sel:metaCanonicalQuery:V4 :: CanonicalQuery
metaCanonicalQuery = CanonicalQuery
query,
      $sel:metaCanonicalRequest:V4 :: CanonicalRequest
metaCanonicalRequest = CanonicalRequest
crq,
      $sel:metaCanonicalHeaders:V4 :: CanonicalHeaders
metaCanonicalHeaders = CanonicalHeaders
chs,
      $sel:metaSignedHeaders:V4 :: SignedHeaders
metaSignedHeaders = SignedHeaders
shs,
      $sel:metaStringToSign:V4 :: StringToSign
metaStringToSign = StringToSign
sts,
      $sel:metaSignature:V4 :: Signature
metaSignature = SecretKey -> CredentialScope -> StringToSign -> Signature
signature (AuthEnv -> Sensitive SecretKey
_authSecretAccessKey AuthEnv
a Sensitive SecretKey
-> Getting SecretKey (Sensitive SecretKey) SecretKey -> SecretKey
forall s a. s -> Getting a s a -> a
^. Getting SecretKey (Sensitive SecretKey) SecretKey
forall a. Iso' (Sensitive a) a
_Sensitive) CredentialScope
scope StringToSign
sts,
      $sel:metaHeaders:V4 :: [Header]
metaHeaders = Request a -> [Header]
forall a. Request a -> [Header]
_requestHeaders Request a
rq,
      $sel:metaTimeout:V4 :: Maybe Seconds
metaTimeout = Service -> Maybe Seconds
_serviceTimeout Service
svc
    }
  where
    query :: CanonicalQuery
query = QueryString -> CanonicalQuery
canonicalQuery (QueryString -> CanonicalQuery)
-> (QueryString -> QueryString) -> QueryString -> CanonicalQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential -> SignedHeaders -> QueryString -> QueryString
presign Credential
cred SignedHeaders
shs (QueryString -> CanonicalQuery) -> QueryString -> CanonicalQuery
forall a b. (a -> b) -> a -> b
$ Request a -> QueryString
forall a. Request a -> QueryString
_requestQuery Request a
rq

    sts :: StringToSign
sts = UTCTime -> CredentialScope -> CanonicalRequest -> StringToSign
stringToSign UTCTime
ts CredentialScope
scope CanonicalRequest
crq
    cred :: Credential
cred = AccessKey -> CredentialScope -> Credential
credential (AuthEnv -> AccessKey
_authAccessKeyId AuthEnv
a) CredentialScope
scope
    scope :: CredentialScope
scope = Service -> Endpoint -> UTCTime -> CredentialScope
credentialScope Service
svc Endpoint
end UTCTime
ts
    crq :: CanonicalRequest
crq = Method
-> Path
-> Hash
-> CanonicalQuery
-> CanonicalHeaders
-> SignedHeaders
-> CanonicalRequest
canonicalRequest Method
method Path
path Hash
digest CanonicalQuery
query CanonicalHeaders
chs SignedHeaders
shs

    chs :: CanonicalHeaders
chs = NormalisedHeaders -> CanonicalHeaders
canonicalHeaders NormalisedHeaders
headers
    shs :: SignedHeaders
shs = NormalisedHeaders -> SignedHeaders
signedHeaders NormalisedHeaders
headers
    headers :: NormalisedHeaders
headers = [Header] -> NormalisedHeaders
normaliseHeaders (Request a -> [Header]
forall a. Request a -> [Header]
_requestHeaders Request a
rq)

    end :: Endpoint
end = Service -> Region -> Endpoint
_serviceEndpoint Service
svc Region
r
    method :: Method
method = ByteString -> Method
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> Method)
-> (StdMethod -> ByteString) -> StdMethod -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (StdMethod -> Method) -> StdMethod -> Method
forall a b. (a -> b) -> a -> b
$ Request a -> StdMethod
forall a. Request a -> StdMethod
_requestMethod Request a
rq
    path :: Path
path = Request a -> Path
forall a. Request a -> Path
escapedPath Request a
rq

    svc :: Service
svc = Request a -> Service
forall a. Request a -> Service
_requestService Request a
rq

algorithm :: ByteString
algorithm :: ByteString
algorithm = ByteString
"AWS4-HMAC-SHA256"

signature :: SecretKey -> CredentialScope -> StringToSign -> Signature
signature :: SecretKey -> CredentialScope -> StringToSign -> Signature
signature SecretKey
k CredentialScope
c = ByteString -> Signature
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> Signature)
-> (StringToSign -> ByteString) -> StringToSign -> Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HMAC SHA256 -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
Bytes.encodeBase16 (HMAC SHA256 -> ByteString)
-> (StringToSign -> HMAC SHA256) -> StringToSign -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> HMAC SHA256
forall a. ByteArrayAccess a => ByteString -> a -> HMAC SHA256
Crypto.hmacSHA256 ByteString
signingKey (ByteString -> HMAC SHA256)
-> (StringToSign -> ByteString) -> StringToSign -> HMAC SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringToSign -> ByteString
forall (s :: Symbol) a. Tag s a -> a
untag
  where
    signingKey :: ByteString
signingKey = (ByteString -> ByteString -> ByteString)
-> ByteString -> [ByteString] -> ByteString
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' ByteString -> ByteString -> ByteString
forall bout a.
(ByteArray bout, ByteArrayAccess a) =>
ByteString -> a -> bout
hmac (ByteString
"AWS4" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> SecretKey -> ByteString
forall a. ToByteString a => a -> ByteString
toBS SecretKey
k) (CredentialScope -> [ByteString]
forall (s :: Symbol) a. Tag s a -> a
untag CredentialScope
c)

    hmac :: ByteString -> a -> bout
hmac ByteString
x a
y = HMAC SHA256 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Bytes.convert (ByteString -> a -> HMAC SHA256
forall a. ByteArrayAccess a => ByteString -> a -> HMAC SHA256
Crypto.hmacSHA256 ByteString
x a
y)

stringToSign :: UTCTime -> CredentialScope -> CanonicalRequest -> StringToSign
stringToSign :: UTCTime -> CredentialScope -> CanonicalRequest -> StringToSign
stringToSign UTCTime
t CredentialScope
c CanonicalRequest
r =
  ByteString -> StringToSign
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> StringToSign) -> ByteString -> StringToSign
forall a b. (a -> b) -> a -> b
$
    ByteString -> [ByteString] -> ByteString
BS8.intercalate
      ByteString
"\n"
      [ ByteString
algorithm,
        AWSTime -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (UTCTime -> AWSTime
forall (a :: Format). UTCTime -> Time a
Time UTCTime
t :: AWSTime),
        CredentialScope -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CredentialScope
c,
        Digest SHA256 -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
Bytes.encodeBase16 (Digest SHA256 -> ByteString)
-> (ByteString -> Digest SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256
forall a. ByteArrayAccess a => a -> Digest SHA256
Crypto.hashSHA256 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CanonicalRequest -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CanonicalRequest
r
      ]

credential :: AccessKey -> CredentialScope -> Credential
credential :: AccessKey -> CredentialScope -> Credential
credential AccessKey
k CredentialScope
c = ByteString -> Credential
forall (s :: Symbol) a. a -> Tag s a
Tag (AccessKey -> ByteString
forall a. ToByteString a => a -> ByteString
toBS AccessKey
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CredentialScope -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CredentialScope
c)

credentialScope :: Service -> Endpoint -> UTCTime -> CredentialScope
credentialScope :: Service -> Endpoint -> UTCTime -> CredentialScope
credentialScope Service
s Endpoint
e UTCTime
t =
  [ByteString] -> CredentialScope
forall (s :: Symbol) a. a -> Tag s a
Tag
    [ BasicTime -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (UTCTime -> BasicTime
forall (a :: Format). UTCTime -> Time a
Time UTCTime
t :: BasicTime),
      ByteString -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (Endpoint -> ByteString
_endpointScope Endpoint
e),
      ByteString -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (Service -> ByteString
_serviceSigningName Service
s),
      ByteString
"aws4_request"
    ]

canonicalRequest ::
  Method ->
  Path ->
  Hash ->
  CanonicalQuery ->
  CanonicalHeaders ->
  SignedHeaders ->
  CanonicalRequest
canonicalRequest :: Method
-> Path
-> Hash
-> CanonicalQuery
-> CanonicalHeaders
-> SignedHeaders
-> CanonicalRequest
canonicalRequest Method
meth Path
path Hash
digest CanonicalQuery
query CanonicalHeaders
chs SignedHeaders
shs =
  ByteString -> CanonicalRequest
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> CanonicalRequest) -> ByteString -> CanonicalRequest
forall a b. (a -> b) -> a -> b
$
    ByteString -> [ByteString] -> ByteString
BS8.intercalate
      ByteString
"\n"
      [ Method -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Method
meth,
        Path -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Path
path,
        CanonicalQuery -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CanonicalQuery
query,
        CanonicalHeaders -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CanonicalHeaders
chs,
        SignedHeaders -> ByteString
forall a. ToByteString a => a -> ByteString
toBS SignedHeaders
shs,
        Hash -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Hash
digest
      ]

escapedPath :: Request a -> Path
escapedPath :: Request a -> Path
escapedPath Request a
r = ByteString -> Path
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> Path)
-> (Path 'NoEncoding -> ByteString) -> Path 'NoEncoding -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EscapedPath -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (EscapedPath -> ByteString)
-> (Path 'NoEncoding -> EscapedPath)
-> Path 'NoEncoding
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path 'NoEncoding -> EscapedPath
forall (a :: Encoding). Path a -> EscapedPath
escapePath (Path 'NoEncoding -> Path) -> Path 'NoEncoding -> Path
forall a b. (a -> b) -> a -> b
$
  case Service -> Abbrev
_serviceAbbrev (Request a -> Service
forall a. Request a -> Service
_requestService Request a
r) of
    Abbrev
"S3" -> Request a -> Path 'NoEncoding
forall a. Request a -> Path 'NoEncoding
_requestPath Request a
r
    Abbrev
_ -> Path 'NoEncoding -> Path 'NoEncoding
forall (a :: Encoding). Path a -> Path a
collapsePath (Request a -> Path 'NoEncoding
forall a. Request a -> Path 'NoEncoding
_requestPath Request a
r)

canonicalQuery :: QueryString -> CanonicalQuery
canonicalQuery :: QueryString -> CanonicalQuery
canonicalQuery = ByteString -> CanonicalQuery
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> CanonicalQuery)
-> (QueryString -> ByteString) -> QueryString -> CanonicalQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryString -> ByteString
forall a. ToByteString a => a -> ByteString
toBS

-- FIXME: the following use of stripBS is too naive, should remove
-- all internal whitespace, replacing with a single space char,
-- unless quoted with \"...\"
canonicalHeaders :: NormalisedHeaders -> CanonicalHeaders
canonicalHeaders :: NormalisedHeaders -> CanonicalHeaders
canonicalHeaders = ByteString -> CanonicalHeaders
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> CanonicalHeaders)
-> (NormalisedHeaders -> ByteString)
-> NormalisedHeaders
-> CanonicalHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap ((ByteString -> ByteString -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> ByteString
f) ([(ByteString, ByteString)] -> ByteString)
-> (NormalisedHeaders -> [(ByteString, ByteString)])
-> NormalisedHeaders
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalisedHeaders -> [(ByteString, ByteString)]
forall (s :: Symbol) a. Tag s a -> a
untag
  where
    f :: ByteString -> ByteString -> ByteString
f ByteString
k ByteString
v = ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
stripBS ByteString
v ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"

signedHeaders :: NormalisedHeaders -> SignedHeaders
signedHeaders :: NormalisedHeaders -> SignedHeaders
signedHeaders = ByteString -> SignedHeaders
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> SignedHeaders)
-> (NormalisedHeaders -> ByteString)
-> NormalisedHeaders
-> SignedHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
BS8.intercalate ByteString
";" ([ByteString] -> ByteString)
-> (NormalisedHeaders -> [ByteString])
-> NormalisedHeaders
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ([(ByteString, ByteString)] -> [ByteString])
-> (NormalisedHeaders -> [(ByteString, ByteString)])
-> NormalisedHeaders
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalisedHeaders -> [(ByteString, ByteString)]
forall (s :: Symbol) a. Tag s a -> a
untag

normaliseHeaders :: [Header] -> NormalisedHeaders
normaliseHeaders :: [Header] -> NormalisedHeaders
normaliseHeaders =
  -- FIXME: convert this to an ordered map.
  [(ByteString, ByteString)] -> NormalisedHeaders
forall (s :: Symbol) a. a -> Tag s a
Tag
    ([(ByteString, ByteString)] -> NormalisedHeaders)
-> ([Header] -> [(ByteString, ByteString)])
-> [Header]
-> NormalisedHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> (ByteString, ByteString))
-> [Header] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> ByteString) -> Header -> (ByteString, ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase)
    ([Header] -> [(ByteString, ByteString)])
-> ([Header] -> [Header]) -> [Header] -> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Header -> Bool) -> [Header] -> [Header]
forall a. (a -> a -> Bool) -> [a] -> [a]
List.nubBy (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (HeaderName -> HeaderName -> Bool)
-> (Header -> HeaderName) -> Header -> Header -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`Function.on` Header -> HeaderName
forall a b. (a, b) -> a
fst)
    ([Header] -> [Header])
-> ([Header] -> [Header]) -> [Header] -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Header -> Ordering) -> [Header] -> [Header]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (HeaderName -> HeaderName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (HeaderName -> HeaderName -> Ordering)
-> (Header -> HeaderName) -> Header -> Header -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`Function.on` Header -> HeaderName
forall a b. (a, b) -> a
fst)
    ([Header] -> [Header])
-> ([Header] -> [Header]) -> [Header] -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"authorization") (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst)
    ([Header] -> [Header])
-> ([Header] -> [Header]) -> [Header] -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"content-length") (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst)