-- |
-- Module      : Amazonka.Sign.V2Header
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
--
-- This module provides an AWS compliant V2 Header request signer. It is based
-- heavily on <https://github.com/boto/boto boto>, specifically boto's
-- @HmacAuthV1Handler@ AWS capable signer. AWS documentation is available
-- <http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html here>.
--
-- Notice: Limitations include an inability to sign with a security token and
-- inability to overwrite the @Date@ header with an expiry.
module Amazonka.Sign.V2Header
  ( v2Header,
    newSigner,
    toSignerQueryBS,
    constructSigningHeader,
    constructSigningQuery,
    constructFullPath,
    unionNecessaryHeaders,
  )
where

import qualified Amazonka.Bytes as Bytes
import qualified Amazonka.Crypto as Crypto
import Amazonka.Data
import qualified Amazonka.Data.Query as Query
import Amazonka.Prelude
import Amazonka.Types
import qualified Data.ByteString.Builder as Build
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.CaseInsensitive as CI
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
import qualified Network.HTTP.Types.URI as URI

data V2Header = V2Header
  { V2Header -> UTCTime
metaTime :: UTCTime,
    V2Header -> Endpoint
metaEndpoint :: Endpoint,
    V2Header -> ByteString
metaSignature :: ByteString,
    V2Header -> RequestHeaders
headers :: HTTP.RequestHeaders,
    V2Header -> ByteString
signer :: ByteString
  }

instance ToLog V2Header where
  build :: V2Header -> ByteStringBuilder
build V2Header {RequestHeaders
ByteString
UTCTime
Endpoint
signer :: ByteString
headers :: RequestHeaders
metaSignature :: ByteString
metaEndpoint :: Endpoint
metaTime :: UTCTime
$sel:signer:V2Header :: V2Header -> ByteString
$sel:headers:V2Header :: V2Header -> RequestHeaders
$sel:metaSignature:V2Header :: V2Header -> ByteString
$sel:metaEndpoint:V2Header :: V2Header -> Endpoint
$sel:metaTime:V2Header :: V2Header -> UTCTime
..} =
    [ByteStringBuilder] -> ByteStringBuilder
buildLines
      [ ByteStringBuilder
"[Version 2 Header 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
"  signature = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build ByteString
metaSignature,
        ByteStringBuilder
"  headers = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> RequestHeaders -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build RequestHeaders
headers,
        ByteStringBuilder
"  signer = " ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteStringBuilder
forall a. ToLog a => a -> ByteStringBuilder
build ByteString
signer,
        ByteStringBuilder
"}"
      ]

v2Header :: Signer
v2Header :: Signer
v2Header = (forall a. Algorithm a)
-> (forall a. Seconds -> Algorithm a) -> Signer
Signer forall a. Algorithm a
sign (Algorithm a -> Seconds -> Algorithm a
forall a b. a -> b -> a
const Algorithm a
forall a. Algorithm a
sign)

sign :: Algorithm a
sign :: Algorithm a
sign Request {RequestHeaders
StdMethod
QueryString
RawPath
RequestBody
Service
$sel:_requestBody:Request :: forall a. Request a -> RequestBody
$sel:_requestHeaders:Request :: forall a. Request a -> RequestHeaders
$sel:_requestQuery:Request :: forall a. Request a -> QueryString
$sel:_requestPath:Request :: forall a. Request a -> RawPath
$sel:_requestMethod:Request :: forall a. Request a -> StdMethod
$sel:_requestService:Request :: forall a. Request a -> Service
_requestBody :: RequestBody
_requestHeaders :: RequestHeaders
_requestQuery :: QueryString
_requestPath :: RawPath
_requestMethod :: StdMethod
_requestService :: Service
..} AuthEnv {Maybe ISO8601
Maybe (Sensitive SessionToken)
Sensitive SecretKey
AccessKey
$sel:_authExpiration:AuthEnv :: AuthEnv -> Maybe ISO8601
$sel:_authSessionToken:AuthEnv :: AuthEnv -> Maybe (Sensitive SessionToken)
$sel:_authSecretAccessKey:AuthEnv :: AuthEnv -> Sensitive SecretKey
$sel:_authAccessKeyId:AuthEnv :: AuthEnv -> AccessKey
_authExpiration :: Maybe ISO8601
_authSessionToken :: Maybe (Sensitive SessionToken)
_authSecretAccessKey :: Sensitive SecretKey
_authAccessKeyId :: AccessKey
..} Region
r UTCTime
t = Meta -> ClientRequest -> Signed a
forall a. Meta -> ClientRequest -> Signed a
Signed Meta
meta ClientRequest
rq
  where
    meta :: Meta
meta = V2Header -> Meta
forall a. ToLog a => a -> Meta
Meta (UTCTime
-> Endpoint
-> ByteString
-> RequestHeaders
-> ByteString
-> V2Header
V2Header UTCTime
t Endpoint
end ByteString
signature RequestHeaders
headers ByteString
signer)

    signer :: ByteString
signer = RequestHeaders
-> ByteString -> ByteString -> QueryString -> ByteString
newSigner RequestHeaders
headers ByteString
meth ByteString
path' QueryString
_requestQuery

    rq :: ClientRequest
rq =
      (Endpoint -> Maybe Seconds -> ClientRequest
newClientRequest Endpoint
end Maybe Seconds
_serviceTimeout)
        { method :: ByteString
Client.method = ByteString
meth,
          path :: ByteString
Client.path = ByteString
path',
          queryString :: ByteString
Client.queryString = QueryString -> ByteString
forall a. ToByteString a => a -> ByteString
toBS QueryString
_requestQuery,
          requestHeaders :: RequestHeaders
Client.requestHeaders = RequestHeaders
headers,
          requestBody :: RequestBody
Client.requestBody = RequestBody -> RequestBody
toRequestBody RequestBody
_requestBody
        }

    meth :: ByteString
meth = StdMethod -> ByteString
forall a. ToByteString a => a -> ByteString
toBS StdMethod
_requestMethod
    path' :: ByteString
path' = EscapedPath -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (RawPath -> EscapedPath
forall (a :: Encoding). Path a -> EscapedPath
escapePath RawPath
_requestPath)

    end :: Endpoint
end@Endpoint {} = Region -> Endpoint
_serviceEndpoint Region
r

    Service {Maybe Seconds
ByteString
Signer
Retry
Abbrev
Status -> Bool
Status -> RequestHeaders -> ByteStringLazy -> Error
Region -> Endpoint
$sel:_serviceRetry:Service :: Service -> Retry
$sel:_serviceError:Service :: Service -> Status -> RequestHeaders -> ByteStringLazy -> Error
$sel:_serviceCheck:Service :: Service -> Status -> Bool
$sel:_serviceTimeout:Service :: Service -> Maybe Seconds
$sel:_serviceEndpoint:Service :: Service -> Region -> Endpoint
$sel:_serviceEndpointPrefix:Service :: Service -> ByteString
$sel:_serviceVersion:Service :: Service -> ByteString
$sel:_serviceSigningName:Service :: Service -> ByteString
$sel:_serviceSigner:Service :: Service -> Signer
$sel:_serviceAbbrev:Service :: Service -> Abbrev
_serviceRetry :: Retry
_serviceError :: Status -> RequestHeaders -> ByteStringLazy -> Error
_serviceCheck :: Status -> Bool
_serviceEndpointPrefix :: ByteString
_serviceVersion :: ByteString
_serviceSigningName :: ByteString
_serviceSigner :: Signer
_serviceAbbrev :: Abbrev
_serviceEndpoint :: Region -> Endpoint
_serviceTimeout :: Maybe Seconds
..} = Service
_requestService

    signature :: ByteString
signature =
      HMAC SHA1 -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
Bytes.encodeBase64
        (HMAC SHA1 -> ByteString)
-> (ByteString -> HMAC SHA1) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> HMAC SHA1
forall a. ByteArrayAccess a => ByteString -> a -> HMAC SHA1
Crypto.hmacSHA1 (Sensitive SecretKey -> ByteString
forall a. ToByteString a => a -> ByteString
toBS Sensitive SecretKey
_authSecretAccessKey)
        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
signer

    headers :: RequestHeaders
headers =
      HeaderName -> ByteString -> RequestHeaders -> RequestHeaders
hdr HeaderName
HTTP.hDate ByteString
time
        (RequestHeaders -> RequestHeaders)
-> (RequestHeaders -> RequestHeaders)
-> RequestHeaders
-> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString -> RequestHeaders -> RequestHeaders
hdr HeaderName
HTTP.hAuthorization (ByteString
"AWS " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> AccessKey -> ByteString
forall a. ToByteString a => a -> ByteString
toBS AccessKey
_authAccessKeyId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
signature)
        (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders
_requestHeaders

    time :: ByteString
time = RFC822 -> ByteString
forall a. ToByteString a => a -> ByteString
toBS (UTCTime -> RFC822
forall (a :: Format). UTCTime -> Time a
Time UTCTime
t :: RFC822)

-- | Construct a full header signer following the V2 Header scheme
newSigner ::
  HTTP.RequestHeaders ->
  ByteString ->
  ByteString ->
  Query.QueryString ->
  ByteString
newSigner :: RequestHeaders
-> ByteString -> ByteString -> QueryString -> ByteString
newSigner RequestHeaders
headers ByteString
method ByteString
path QueryString
query = ByteString
signer
  where
    signer :: ByteString
signer =
      ByteString -> [ByteString] -> ByteString
BS8.intercalate
        ByteString
"\n"
        ( ByteString
method ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
          (Header -> ByteString) -> RequestHeaders -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Header -> ByteString
constructSigningHeader (RequestHeaders -> RequestHeaders
forall a. Ord a => [a] -> [a]
List.sort RequestHeaders
filteredHeaders)
            [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString -> ByteString -> ByteString
constructFullPath ByteString
path (QueryString -> ByteString
toSignerQueryBS QueryString
filteredQuery)]
        )

    filteredHeaders :: RequestHeaders
filteredHeaders = RequestHeaders -> RequestHeaders
unionNecessaryHeaders ((Header -> Bool) -> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
isInterestingHeader RequestHeaders
headers)

    filteredQuery :: QueryString
filteredQuery = QueryString -> QueryString
constructSigningQuery QueryString
query

-- | The following function mostly follows the toBS in amazonka QueryString
-- except for single QValue or single QPair keys not being suffixed with
-- an equals.
toSignerQueryBS :: Query.QueryString -> ByteString
toSignerQueryBS :: QueryString -> ByteString
toSignerQueryBS =
  ByteStringLazy -> ByteString
LBS.toStrict (ByteStringLazy -> ByteString)
-> (QueryString -> ByteStringLazy) -> QueryString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringBuilder -> ByteStringLazy
Build.toLazyByteString (ByteStringBuilder -> ByteStringLazy)
-> (QueryString -> ByteStringBuilder)
-> QueryString
-> ByteStringLazy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteStringBuilder
cat ([ByteString] -> ByteStringBuilder)
-> (QueryString -> [ByteString])
-> QueryString
-> ByteStringBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
List.sort ([ByteString] -> [ByteString])
-> (QueryString -> [ByteString]) -> QueryString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> QueryString -> [ByteString]
enc Maybe ByteString
forall a. Maybe a
Nothing
  where
    enc :: Maybe ByteString -> Query.QueryString -> [ByteString]
    enc :: Maybe ByteString -> QueryString -> [ByteString]
enc Maybe ByteString
p = \case
      Query.QList [QueryString]
xs -> (QueryString -> [ByteString]) -> [QueryString] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe ByteString -> QueryString -> [ByteString]
enc Maybe ByteString
p) [QueryString]
xs
      Query.QPair (Bool -> ByteString -> ByteString
URI.urlEncode Bool
True -> ByteString
k) QueryString
x
        | Just ByteString
n <- Maybe ByteString
p -> Maybe ByteString -> QueryString -> [ByteString]
enc (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
kdelim ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
k)) QueryString
x -- <prev>.key <recur>
        | Bool
otherwise -> Maybe ByteString -> QueryString -> [ByteString]
enc (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
k) QueryString
x -- key <recur>
      Query.QValue (Just (Bool -> ByteString -> ByteString
URI.urlEncode Bool
True -> ByteString
v))
        | Just ByteString
n <- Maybe ByteString
p -> [ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
vsep ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v] -- key=value
        | Bool
otherwise -> [ByteString
v]
      QueryString
_
        | Just ByteString
n <- Maybe ByteString
p -> [ByteString
n]
        | Bool
otherwise -> []

    cat :: [ByteString] -> ByteStringBuilder
    cat :: [ByteString] -> ByteStringBuilder
cat [] = ByteStringBuilder
forall a. Monoid a => a
mempty
    cat [ByteString
x] = ByteString -> ByteStringBuilder
Build.byteString ByteString
x
    cat (ByteString
x : [ByteString]
xs) = ByteString -> ByteStringBuilder
Build.byteString ByteString
x ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> ByteStringBuilder
ksep ByteStringBuilder -> ByteStringBuilder -> ByteStringBuilder
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> ByteStringBuilder
cat [ByteString]
xs

    kdelim :: ByteString
kdelim = ByteString
"."
    ksep :: ByteStringBuilder
ksep = ByteStringBuilder
"&"
    vsep :: ByteString
vsep = ByteString
"="

hasAWSPrefix :: CI.CI ByteString -> Bool
hasAWSPrefix :: HeaderName -> Bool
hasAWSPrefix = ByteString -> ByteString -> Bool
BS8.isPrefixOf ByteString
"aws-" (ByteString -> Bool)
-> (HeaderName -> ByteString) -> HeaderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase

-- | Filter for 'interesting' keys within a QueryString
isInterestingQueryKey :: ByteString -> Bool
isInterestingQueryKey :: ByteString -> Bool
isInterestingQueryKey = \case
  ByteString
"acl" -> Bool
True
  ByteString
"cors" -> Bool
True
  ByteString
"defaultObjectAcl" -> Bool
True
  ByteString
"location" -> Bool
True
  ByteString
"logging" -> Bool
True
  ByteString
"partNumber" -> Bool
True
  ByteString
"policy" -> Bool
True
  ByteString
"requestPayment" -> Bool
True
  ByteString
"torrent" -> Bool
True
  ByteString
"versioning" -> Bool
True
  ByteString
"versionId" -> Bool
True
  ByteString
"versions" -> Bool
True
  ByteString
"website" -> Bool
True
  ByteString
"uploads" -> Bool
True
  ByteString
"uploadId" -> Bool
True
  ByteString
"response-content-type" -> Bool
True
  ByteString
"response-content-language" -> Bool
True
  ByteString
"response-expires" -> Bool
True
  ByteString
"response-cache-control" -> Bool
True
  ByteString
"response-content-disposition" -> Bool
True
  ByteString
"response-content-encoding" -> Bool
True
  ByteString
"delete" -> Bool
True
  ByteString
"lifecycle" -> Bool
True
  ByteString
"tagging" -> Bool
True
  ByteString
"restore" -> Bool
True
  ByteString
"storageClass" -> Bool
True
  ByteString
"websiteConfig" -> Bool
True
  ByteString
"compose" -> Bool
True
  ByteString
_ -> Bool
False

-- | Filter for 'interesting' header fields
isInterestingHeader :: HTTP.Header -> Bool
isInterestingHeader :: Header -> Bool
isInterestingHeader (HeaderName
name, ByteString
_)
  | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hDate = Bool
True
  | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hContentMD5 = Bool
True
  | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hContentType = Bool
True
  | HeaderName -> Bool
hasAWSPrefix HeaderName
name = Bool
True
  | Bool
otherwise = Bool
False

-- | Constructs a query string for signing
constructSigningQuery :: Query.QueryString -> Query.QueryString
constructSigningQuery :: QueryString -> QueryString
constructSigningQuery = \case
  Query.QValue {} -> Maybe ByteString -> QueryString
Query.QValue Maybe ByteString
forall a. Maybe a
Nothing
  Query.QList [QueryString]
qs -> [QueryString] -> QueryString
Query.QList ((QueryString -> QueryString) -> [QueryString] -> [QueryString]
forall a b. (a -> b) -> [a] -> [b]
map QueryString -> QueryString
constructSigningQuery [QueryString]
qs)
  Query.QPair ByteString
k QueryString
v
    | ByteString -> Bool
isInterestingQueryKey ByteString
k -> ByteString -> QueryString -> QueryString
Query.QPair ByteString
k QueryString
v
    | Bool
otherwise -> Maybe ByteString -> QueryString
Query.QValue Maybe ByteString
forall a. Maybe a
Nothing

-- | Construct a header string for signing
constructSigningHeader :: HTTP.Header -> ByteString
constructSigningHeader :: Header -> ByteString
constructSigningHeader (HeaderName
name, ByteString
value)
  | HeaderName -> Bool
hasAWSPrefix HeaderName
name = HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase HeaderName
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
value
  | Bool
otherwise = ByteString
value

constructFullPath :: ByteString -> ByteString -> ByteString
constructFullPath :: ByteString -> ByteString -> ByteString
constructFullPath ByteString
path ByteString
q
  | ByteString -> Bool
BS8.null ByteString
q = ByteString
path
  | Bool
otherwise = ByteString
path ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"?" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
q

unionNecessaryHeaders :: [HTTP.Header] -> [HTTP.Header]
unionNecessaryHeaders :: RequestHeaders -> RequestHeaders
unionNecessaryHeaders =
  (RequestHeaders -> RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders -> RequestHeaders
forall a b c. (a -> b -> c) -> b -> a -> c
flip
    ((Header -> Header -> Bool)
-> RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
List.unionBy ((HeaderName -> HeaderName -> Bool)
-> (Header -> HeaderName) -> Header -> Header -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
Function.on HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) Header -> HeaderName
forall a b. (a, b) -> a
fst))
    [ (HeaderName
HTTP.hContentMD5, ByteString
""),
      (HeaderName
HTTP.hContentType, ByteString
"")
    ]