-- |
-- Module      : Amazonka.Sign.V4.Base
-- Copyright   : (c) 2013-2023 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 Amazonka.Core.Lens.Internal ((<>~), (^.))
import qualified Amazonka.Crypto as Crypto
import Amazonka.Data hiding (Path)
import Amazonka.Prelude
import Amazonka.Request
import Amazonka.Types
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Foldable
import qualified Data.Map.Strict as Map
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 -> Builder
build V4 {$sel:metaEndpoint:V4 :: V4 -> Endpoint
metaEndpoint = Endpoint {ByteString
host :: ByteString
$sel:host:Endpoint :: Endpoint -> ByteString
host}, [Header]
Maybe Seconds
UTCTime
Method
Path
Signature
Credential
CanonicalRequest
StringToSign
CanonicalQuery
CanonicalHeaders
SignedHeaders
$sel:metaTime:V4 :: V4 -> UTCTime
$sel:metaMethod:V4 :: V4 -> Method
$sel:metaPath:V4 :: V4 -> Path
$sel:metaCredential:V4 :: V4 -> Credential
$sel:metaCanonicalQuery:V4 :: V4 -> CanonicalQuery
$sel:metaCanonicalRequest:V4 :: V4 -> CanonicalRequest
$sel:metaCanonicalHeaders:V4 :: V4 -> CanonicalHeaders
$sel:metaSignedHeaders:V4 :: V4 -> SignedHeaders
$sel:metaStringToSign:V4 :: V4 -> StringToSign
$sel:metaSignature:V4 :: V4 -> Signature
$sel:metaHeaders:V4 :: V4 -> [Header]
$sel:metaTimeout:V4 :: V4 -> Maybe Seconds
metaTime :: UTCTime
metaMethod :: Method
metaPath :: Path
metaCredential :: Credential
metaCanonicalQuery :: CanonicalQuery
metaCanonicalRequest :: CanonicalRequest
metaCanonicalHeaders :: CanonicalHeaders
metaSignedHeaders :: SignedHeaders
metaStringToSign :: StringToSign
metaSignature :: Signature
metaHeaders :: [Header]
metaTimeout :: Maybe Seconds
..} =
    [Builder] -> Builder
buildLines
      [ Builder
"[Version 4 Metadata] {",
        Builder
"  time              = " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> UTCTime -> Builder
forall a. ToLog a => a -> Builder
build UTCTime
metaTime,
        Builder
"  endpoint          = " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
forall a. ToLog a => a -> Builder
build ByteString
host,
        Builder
"  credential        = " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Credential -> Builder
forall a. ToLog a => a -> Builder
build Credential
metaCredential,
        Builder
"  signed headers    = " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SignedHeaders -> Builder
forall a. ToLog a => a -> Builder
build SignedHeaders
metaSignedHeaders,
        Builder
"  signature         = " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Signature -> Builder
forall a. ToLog a => a -> Builder
build Signature
metaSignature,
        Builder
"  string to sign    = {",
        StringToSign -> Builder
forall a. ToLog a => a -> Builder
build StringToSign
metaStringToSign,
        Builder
"  }",
        Builder
"  canonical request = {",
        CanonicalRequest -> Builder
forall a. ToLog a => a -> Builder
build CanonicalRequest
metaCanonicalRequest,
        Builder
"  }",
        Builder
"}"
      ]

base ::
  Hash ->
  Request a ->
  AuthEnv ->
  Region ->
  UTCTime ->
  (V4, ClientRequest -> ClientRequest)
base :: forall a.
Hash
-> Request a
-> AuthEnv
-> Region
-> UTCTime
-> (V4, ClientRequest -> ClientRequest)
base Hash
h Request a
rq AuthEnv
a Region
region 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
<>~ [(CI ByteString
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
region UTCTime
ts Credential -> SignedHeaders -> QueryString -> QueryString
forall {p} {p} {a}. p -> p -> a -> a
presigner Hash
h (Request a -> Request a
forall a. 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 :: forall a. Request a -> Request a
prepare r :: Request a
r@Request {[Header]
headers :: [Header]
$sel:headers:Request :: forall a. Request a -> [Header]
headers} =
      Request a
r
        { $sel:headers:Request :: [Header]
headers =
            [Header]
headers
              [Header] -> ([Header] -> [Header]) -> [Header]
forall a b. a -> (a -> b) -> b
& CI ByteString -> ByteString -> [Header] -> [Header]
hdr CI ByteString
hHost ByteString
realHost
              [Header] -> ([Header] -> [Header]) -> [Header]
forall a b. a -> (a -> b) -> b
& CI ByteString -> ByteString -> [Header] -> [Header]
hdr CI ByteString
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]
forall a b. a -> (a -> b) -> b
& CI ByteString -> ByteString -> [Header] -> [Header]
hdr CI ByteString
hAMZContentSHA256 (Hash -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Hash
h)
              [Header] -> ([Header] -> [Header]) -> [Header]
forall a b. a -> (a -> b) -> b
& ([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 (CI ByteString -> ByteString -> [Header] -> [Header]
hdr CI ByteString
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)
sessionToken AuthEnv
a)
        }

    realHost :: ByteString
realHost =
      case (Bool
secure, Int
port) of
        (Bool
False, Int
80) -> ByteString
host
        (Bool
True, Int
443) -> ByteString
host
        (Bool, Int)
_ -> [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString
host, ByteString
":", Int -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Int
port]

    Endpoint {ByteString
$sel:host:Endpoint :: Endpoint -> ByteString
host :: ByteString
host, Int
port :: Int
$sel:port:Endpoint :: Endpoint -> Int
port, Bool
secure :: Bool
$sel:secure:Endpoint :: Endpoint -> Bool
secure} = Service -> Region -> Endpoint
endpoint (Request a -> Service
forall a. Request a -> Service
service Request a
rq) Region
region

-- | 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 {forall (s :: Symbol) a. 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
$cshowsPrec :: forall (s :: Symbol) a. Show a => Int -> Tag s a -> ShowS
showsPrec :: Int -> Tag s a -> ShowS
$cshow :: forall (s :: Symbol) a. Show a => Tag s a -> String
show :: Tag s a -> String
$cshowList :: forall (s :: Symbol) a. Show a => [Tag s a] -> ShowS
showList :: [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 -> Builder
build = ByteString -> Builder
forall a. ToLog a => a -> Builder
build (ByteString -> Builder)
-> (Tag s ByteString -> ByteString) -> Tag s ByteString -> Builder
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 CanonicalPath = Tag "canonical-path" ByteString

type Path = Tag "path" ByteString

type Signature = Tag "signature" ByteString

authorisation :: V4 -> ByteString
authorisation :: V4 -> ByteString
authorisation V4 {[Header]
Maybe Seconds
UTCTime
Endpoint
Method
Path
Signature
Credential
CanonicalRequest
StringToSign
CanonicalQuery
CanonicalHeaders
SignedHeaders
$sel:metaTime:V4 :: V4 -> UTCTime
$sel:metaMethod:V4 :: V4 -> Method
$sel:metaPath:V4 :: V4 -> Path
$sel:metaEndpoint:V4 :: V4 -> Endpoint
$sel:metaCredential:V4 :: V4 -> Credential
$sel:metaCanonicalQuery:V4 :: V4 -> CanonicalQuery
$sel:metaCanonicalRequest:V4 :: V4 -> CanonicalRequest
$sel:metaCanonicalHeaders:V4 :: V4 -> CanonicalHeaders
$sel:metaSignedHeaders:V4 :: V4 -> SignedHeaders
$sel:metaStringToSign:V4 :: V4 -> StringToSign
$sel:metaSignature:V4 :: V4 -> Signature
$sel:metaHeaders:V4 :: V4 -> [Header]
$sel:metaTimeout:V4 :: V4 -> Maybe Seconds
metaTime :: UTCTime
metaMethod :: Method
metaPath :: Path
metaEndpoint :: Endpoint
metaCredential :: Credential
metaCanonicalQuery :: CanonicalQuery
metaCanonicalRequest :: CanonicalRequest
metaCanonicalHeaders :: CanonicalHeaders
metaSignedHeaders :: SignedHeaders
metaStringToSign :: StringToSign
metaSignature :: Signature
metaHeaders :: [Header]
metaTimeout :: Maybe Seconds
..} =
  [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString
algorithm,
      ByteString
" Credential=",
      Credential -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Credential
metaCredential,
      ByteString
", SignedHeaders=",
      SignedHeaders -> ByteString
forall a. ToByteString a => a -> ByteString
toBS SignedHeaders
metaSignedHeaders,
      ByteString
", Signature=",
      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 :: forall a.
V4 -> RequestBody -> (ClientRequest -> ClientRequest) -> Signed a
signRequest m :: V4
m@V4 {[Header]
Maybe Seconds
UTCTime
Endpoint
Method
Path
Signature
Credential
CanonicalRequest
StringToSign
CanonicalQuery
CanonicalHeaders
SignedHeaders
$sel:metaTime:V4 :: V4 -> UTCTime
$sel:metaMethod:V4 :: V4 -> Method
$sel:metaPath:V4 :: V4 -> Path
$sel:metaEndpoint:V4 :: V4 -> Endpoint
$sel:metaCredential:V4 :: V4 -> Credential
$sel:metaCanonicalQuery:V4 :: V4 -> CanonicalQuery
$sel:metaCanonicalRequest:V4 :: V4 -> CanonicalRequest
$sel:metaCanonicalHeaders:V4 :: V4 -> CanonicalHeaders
$sel:metaSignedHeaders:V4 :: V4 -> SignedHeaders
$sel:metaStringToSign:V4 :: V4 -> StringToSign
$sel:metaSignature:V4 :: V4 -> Signature
$sel:metaHeaders:V4 :: V4 -> [Header]
$sel:metaTimeout:V4 :: V4 -> Maybe Seconds
metaTime :: UTCTime
metaMethod :: Method
metaPath :: Path
metaEndpoint :: Endpoint
metaCredential :: Credential
metaCanonicalQuery :: CanonicalQuery
metaCanonicalRequest :: CanonicalRequest
metaCanonicalHeaders :: CanonicalHeaders
metaSignedHeaders :: SignedHeaders
metaStringToSign :: StringToSign
metaSignature :: Signature
metaHeaders :: [Header]
metaTimeout :: Maybe Seconds
..} 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 :: forall a.
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 rq :: Request a
rq@Request {[Header]
$sel:headers:Request :: forall a. Request a -> [Header]
headers :: [Header]
headers, StdMethod
method :: StdMethod
$sel:method:Request :: forall a. Request a -> StdMethod
method, QueryString
query :: QueryString
$sel:query:Request :: forall a. Request a -> QueryString
query, Service
$sel:service:Request :: forall a. Request a -> Service
service :: Service
service} =
  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
secretAccessKey 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 (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p (Sensitive a) (f (Sensitive a))
_Sensitive) CredentialScope
scope StringToSign
sts,
      $sel:metaHeaders:V4 :: [Header]
metaHeaders = [Header]
headers,
      $sel:metaTimeout:V4 :: Maybe Seconds
metaTimeout = Service -> Maybe Seconds
timeout Service
service
    }
  where
    query' :: CanonicalQuery
query' = QueryString -> CanonicalQuery
canonicalQuery (QueryString -> CanonicalQuery) -> QueryString -> CanonicalQuery
forall a b. (a -> b) -> a -> b
$ Credential -> SignedHeaders -> QueryString -> QueryString
presign Credential
cred SignedHeaders
shs QueryString
query

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

    chs :: CanonicalHeaders
chs = NormalisedHeaders -> CanonicalHeaders
canonicalHeaders NormalisedHeaders
normalisedHeaders
    shs :: SignedHeaders
shs = NormalisedHeaders -> SignedHeaders
signedHeaders NormalisedHeaders
normalisedHeaders
    normalisedHeaders :: NormalisedHeaders
normalisedHeaders = [Header] -> NormalisedHeaders
normaliseHeaders [Header]
headers

    end :: Endpoint
end = Service -> Region -> Endpoint
endpoint Service
service Region
r
    method' :: Method
method' = ByteString -> Method
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> Method) -> ByteString -> Method
forall a b. (a -> b) -> a -> b
$ StdMethod -> ByteString
forall a. ToByteString a => a -> ByteString
toBS StdMethod
method
    path :: Path
path = Region -> Request a -> Path
forall a. Region -> Request a -> Path
escapedPath Region
r Request a
rq
    cpath :: CanonicalPath
cpath = Region -> Request a -> CanonicalPath
forall a. Region -> Request a -> CanonicalPath
canonicalPath Region
r 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 b a. (b -> a -> b) -> b -> [a] -> b
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 {ByteString
signingName :: ByteString
$sel:signingName:Service :: Service -> ByteString
signingName} Endpoint {ByteString
scope :: ByteString
$sel:scope:Endpoint :: Endpoint -> ByteString
scope} 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 ByteString
scope,
      ByteString -> ByteString
forall a. ToByteString a => a -> ByteString
toBS ByteString
signingName,
      ByteString
"aws4_request"
    ]

canonicalRequest ::
  Method ->
  CanonicalPath ->
  Hash ->
  CanonicalQuery ->
  CanonicalHeaders ->
  SignedHeaders ->
  CanonicalRequest
canonicalRequest :: Method
-> CanonicalPath
-> Hash
-> CanonicalQuery
-> CanonicalHeaders
-> SignedHeaders
-> CanonicalRequest
canonicalRequest Method
meth CanonicalPath
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,
        CanonicalPath -> ByteString
forall a. ToByteString a => a -> ByteString
toBS CanonicalPath
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 :: Region -> Request a -> Path
escapedPath :: forall a. Region -> Request a -> Path
escapedPath Region
r rq :: Request a
rq@Request {$sel:service:Request :: forall a. Request a -> Service
service = Service {Abbrev
abbrev :: Abbrev
$sel:abbrev:Service :: Service -> Abbrev
abbrev}} =
  ByteString -> Path
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> Path) -> ByteString -> Path
forall a b. (a -> b) -> a -> b
$ case Abbrev
abbrev of
    Abbrev
"S3" -> EscapedPath -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (EscapedPath -> ByteString) -> EscapedPath -> ByteString
forall a b. (a -> b) -> a -> b
$ Path 'NoEncoding -> EscapedPath
forall (a :: Encoding). Path a -> EscapedPath
escapePath Path 'NoEncoding
p
    Abbrev
_ -> EscapedPath -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (EscapedPath -> ByteString) -> EscapedPath -> ByteString
forall a b. (a -> b) -> a -> b
$ Path 'NoEncoding -> EscapedPath
forall (a :: Encoding). Path a -> EscapedPath
escapePath (Path 'NoEncoding -> EscapedPath)
-> Path 'NoEncoding -> EscapedPath
forall a b. (a -> b) -> a -> b
$ Path 'NoEncoding -> Path 'NoEncoding
forall (a :: Encoding). Path a -> Path a
collapsePath Path 'NoEncoding
p
  where
    p :: Path 'NoEncoding
p = Region -> Request a -> Path 'NoEncoding
forall a. Region -> Request a -> Path 'NoEncoding
fullRawPath Region
r Request a
rq

canonicalPath :: Region -> Request a -> CanonicalPath
canonicalPath :: forall a. Region -> Request a -> CanonicalPath
canonicalPath Region
r rq :: Request a
rq@Request {$sel:service:Request :: forall a. Request a -> Service
service = Service {Abbrev
$sel:abbrev:Service :: Service -> Abbrev
abbrev :: Abbrev
abbrev}} =
  ByteString -> CanonicalPath
forall (s :: Symbol) a. a -> Tag s a
Tag (ByteString -> CanonicalPath) -> ByteString -> CanonicalPath
forall a b. (a -> b) -> a -> b
$ case Abbrev
abbrev of
    Abbrev
"S3" -> EscapedPath -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (EscapedPath -> ByteString) -> EscapedPath -> ByteString
forall a b. (a -> b) -> a -> b
$ Path 'NoEncoding -> EscapedPath
forall (a :: Encoding). Path a -> EscapedPath
escapePath Path 'NoEncoding
p
    Abbrev
_ -> TwiceEscapedPath -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (TwiceEscapedPath -> ByteString) -> TwiceEscapedPath -> ByteString
forall a b. (a -> b) -> a -> b
$ Path 'NoEncoding -> TwiceEscapedPath
forall (a :: Encoding). Path a -> TwiceEscapedPath
escapePathTwice (Path 'NoEncoding -> TwiceEscapedPath)
-> Path 'NoEncoding -> TwiceEscapedPath
forall a b. (a -> b) -> a -> b
$ Path 'NoEncoding -> Path 'NoEncoding
forall (a :: Encoding). Path a -> Path a
collapsePath Path 'NoEncoding
p
  where
    p :: Path 'NoEncoding
p = Region -> Request a -> Path 'NoEncoding
forall a. Region -> Request a -> Path 'NoEncoding
fullRawPath Region
r Request a
rq

-- | The complete raw path for a request, including any 'basePath' on
-- the endpoint.
fullRawPath :: Region -> Request a -> RawPath
fullRawPath :: forall a. Region -> Request a -> Path 'NoEncoding
fullRawPath Region
r Request {Path 'NoEncoding
path :: Path 'NoEncoding
$sel:path:Request :: forall a. Request a -> Path 'NoEncoding
path, $sel:service:Request :: forall a. Request a -> Service
service = Service {Region -> Endpoint
$sel:endpoint:Service :: Service -> Region -> Endpoint
endpoint :: Region -> Endpoint
endpoint}} =
  Endpoint -> Path 'NoEncoding
basePath (Region -> Endpoint
endpoint Region
r) Path 'NoEncoding -> Path 'NoEncoding -> Path 'NoEncoding
forall a. Semigroup a => a -> a -> a
<> Path 'NoEncoding
path

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
BSL.toStrict (ByteString -> ByteString)
-> (NormalisedHeaders -> ByteString)
-> NormalisedHeaders
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString (Builder -> ByteString)
-> (NormalisedHeaders -> Builder)
-> NormalisedHeaders
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> Builder)
-> [(ByteString, ByteString)] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap ((ByteString -> ByteString -> Builder)
-> (ByteString, ByteString) -> Builder
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Builder
f) ([(ByteString, ByteString)] -> Builder)
-> (NormalisedHeaders -> [(ByteString, ByteString)])
-> NormalisedHeaders
-> Builder
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 -> Builder
f ByteString
k ByteString
v = ByteString -> Builder
BSB.byteString ByteString
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char7 Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString (ByteString -> ByteString
stripBS ByteString
v) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char7 Char
'\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 =
  [(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 ((CI ByteString -> ByteString) -> Header -> (ByteString, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CI ByteString -> 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
. Map (CI ByteString) ByteString -> [Header]
forall k a. Map k a -> [(k, a)]
Map.toAscList
    (Map (CI ByteString) ByteString -> [Header])
-> ([Header] -> Map (CI ByteString) ByteString)
-> [Header]
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString
-> Map (CI ByteString) ByteString -> Map (CI ByteString) ByteString
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete CI ByteString
"authorization"
    (Map (CI ByteString) ByteString -> Map (CI ByteString) ByteString)
-> ([Header] -> Map (CI ByteString) ByteString)
-> [Header]
-> Map (CI ByteString) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString
-> Map (CI ByteString) ByteString -> Map (CI ByteString) ByteString
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete CI ByteString
"content-length"
    (Map (CI ByteString) ByteString -> Map (CI ByteString) ByteString)
-> ([Header] -> Map (CI ByteString) ByteString)
-> [Header]
-> Map (CI ByteString) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString)
-> [Header] -> Map (CI ByteString) ByteString
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const