-- |
-- 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 hiding (presign, sign)
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
UTCTime
ByteString
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      = " forall a. Semigroup a => a -> a -> a
<> forall a. ToLog a => a -> ByteStringBuilder
build UTCTime
metaTime,
        ByteStringBuilder
"  endpoint  = " forall a. Semigroup a => a -> a -> a
<> forall a. ToLog a => a -> ByteStringBuilder
build (Endpoint -> ByteString
host Endpoint
metaEndpoint),
        ByteStringBuilder
"  signature = " forall a. Semigroup a => a -> a -> a
<> forall a. ToLog a => a -> ByteStringBuilder
build ByteString
metaSignature,
        ByteStringBuilder
"  headers = " forall a. Semigroup a => a -> a -> a
<> forall a. ToLog a => a -> ByteStringBuilder
build RequestHeaders
headers,
        ByteStringBuilder
"  signer = " forall a. Semigroup a => a -> a -> a
<> 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 (forall a b. a -> b -> a
const forall a. Algorithm a
sign)

sign :: Algorithm a
sign :: forall a. Algorithm a
sign Request {RequestHeaders
StdMethod
QueryString
Path 'NoEncoding
RequestBody
Service
$sel:body:Request :: forall a. Request a -> RequestBody
$sel:headers:Request :: forall a. Request a -> RequestHeaders
$sel:query:Request :: forall a. Request a -> QueryString
$sel:path:Request :: forall a. Request a -> Path 'NoEncoding
$sel:method:Request :: forall a. Request a -> StdMethod
$sel:service:Request :: forall a. Request a -> Service
body :: RequestBody
headers :: RequestHeaders
query :: QueryString
path :: Path 'NoEncoding
method :: StdMethod
service :: Service
..} AuthEnv {Maybe ISO8601
Maybe (Sensitive SessionToken)
Sensitive SecretKey
AccessKey
$sel:expiration:AuthEnv :: AuthEnv -> Maybe ISO8601
$sel:sessionToken:AuthEnv :: AuthEnv -> Maybe (Sensitive SessionToken)
$sel:secretAccessKey:AuthEnv :: AuthEnv -> Sensitive SecretKey
$sel:accessKeyId:AuthEnv :: AuthEnv -> AccessKey
expiration :: Maybe ISO8601
sessionToken :: Maybe (Sensitive SessionToken)
secretAccessKey :: Sensitive SecretKey
accessKeyId :: AccessKey
..} Region
r UTCTime
t = forall a. Meta -> ClientRequest -> Signed a
Signed Meta
meta ClientRequest
rq
  where
    meta :: Meta
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
query

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

    meth :: ByteString
meth = forall a. ToByteString a => a -> ByteString
toBS StdMethod
method
    path' :: ByteString
path' = forall a. ToByteString a => a -> ByteString
toBS (forall (a :: Encoding). Path a -> EscapedPath
escapePath forall a b. (a -> b) -> a -> b
$ Path 'NoEncoding
basePath forall a. Semigroup a => a -> a -> a
<> Path 'NoEncoding
path)

    end :: Endpoint
end@Endpoint {Path 'NoEncoding
$sel:basePath:Endpoint :: Endpoint -> Path 'NoEncoding
basePath :: Path 'NoEncoding
basePath} = Region -> Endpoint
endpoint Region
r

    Service {Maybe Seconds
$sel:timeout:Service :: Service -> Maybe Seconds
timeout :: Maybe Seconds
timeout, Region -> Endpoint
$sel:endpoint:Service :: Service -> Region -> Endpoint
endpoint :: Region -> Endpoint
endpoint} = Service
service

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

    headers' :: RequestHeaders
headers' =
      RequestHeaders
headers
        forall a b. a -> (a -> b) -> b
& HeaderName -> ByteString -> RequestHeaders -> RequestHeaders
hdr HeaderName
HTTP.hAuthorization (ByteString
"AWS " forall a. Semigroup a => a -> a -> a
<> forall a. ToByteString a => a -> ByteString
toBS AccessKey
accessKeyId forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> ByteString
signature)
        forall a b. a -> (a -> b) -> b
& HeaderName -> ByteString -> RequestHeaders -> RequestHeaders
hdr HeaderName
HTTP.hDate ByteString
time

    time :: ByteString
time = forall a. ToByteString a => a -> ByteString
toBS (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
            forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Header -> ByteString
constructSigningHeader (forall a. Ord a => [a] -> [a]
List.sort RequestHeaders
filteredHeaders)
            forall a. [a] -> [a] -> [a]
++ [ByteString -> ByteString -> ByteString
constructFullPath ByteString
path (QueryString -> ByteString
toSignerQueryBS QueryString
filteredQuery)]
        )

    filteredHeaders :: RequestHeaders
filteredHeaders = RequestHeaders -> RequestHeaders
unionNecessaryHeaders (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 =
  ByteString -> ByteString
LBS.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringBuilder -> ByteString
Build.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteStringBuilder
cat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
List.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> QueryString -> [ByteString]
enc 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 -> 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 (forall a. a -> Maybe a
Just (ByteString
n forall a. Semigroup a => a -> a -> a
<> ByteString
kdelim forall a. Semigroup a => a -> a -> a
<> ByteString
k)) QueryString
x -- <prev>.key <recur>
        | Bool
otherwise -> Maybe ByteString -> QueryString -> [ByteString]
enc (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 forall a. Semigroup a => a -> a -> a
<> ByteString
vsep 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 [] = 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 forall a. Semigroup a => a -> a -> a
<> ByteStringBuilder
ksep 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-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hDate = Bool
True
  | HeaderName
name forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hContentMD5 = Bool
True
  | HeaderName
name 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 forall a. Maybe a
Nothing
  Query.QList [QueryString]
qs -> [QueryString] -> QueryString
Query.QList (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 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 = forall s. CI s -> s
CI.foldedCase HeaderName
name forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> ByteString
"?" forall a. Semigroup a => a -> a -> a
<> ByteString
q

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