{-# LANGUAGE OverloadedStrings, BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Network.Wreq.Internal.AWS
    (
      signRequest,
      signRequestFull
    ) where

import Control.Applicative ((<$>))
import Control.Lens ((%~), (^.), (&), to)
import Crypto.MAC.HMAC (HMAC (..), hmac, hmacGetDigest)
import Data.ByteString.Base16 as HEX (encode)
import Data.ByteArray (convert)
import Data.Char (toLower)
import Data.List (sort)
import Data.Monoid ((<>))
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Data.Time.LocalTime (utc, utcToLocalTime)
import Network.HTTP.Types (parseSimpleQuery, urlEncode)
import Network.Wreq.Internal.Lens
import Network.Wreq.Internal.Types (AWSAuthVersion(..))
import qualified Crypto.Hash as CT (Digest, SHA256, hash, hashlazy)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8  as L
import qualified Data.CaseInsensitive  as CI (original)
import qualified Data.HashSet as HashSet
import qualified Network.HTTP.Client as HTTP

-- Sign requests following the AWS v4 request signing specification:
-- http://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html
--
-- Runscope Inc. Traffic Inspector support:
-- We support (optionally) sending requests through the Runscope
-- (http://www.runscope.com) Traffic Inspector. If given a Runscope
-- URL to an AWS service, we will extract and correctly sign the
-- request for the underlying AWS service. We support Runscope buckets
-- with and without Bucket Authorization enabled
-- ("Runscope-Bucket-Auth").
--
-- TODO: adjust when DELETE supports a body or PATCH is added
signRequest :: AWSAuthVersion -> S.ByteString -> S.ByteString ->
               Request -> IO Request
signRequest :: AWSAuthVersion -> ByteString -> ByteString -> Request -> IO Request
signRequest AWSAuthVersion
AWSv4 ByteString
aid ByteString
key Request
r = AWSAuthVersion
-> ByteString
-> ByteString
-> Maybe (ByteString, ByteString)
-> Request
-> IO Request
signRequestFull AWSAuthVersion
AWSv4 ByteString
aid ByteString
key forall a. Maybe a
Nothing Request
r

hexSha256Hash :: S.ByteString -> S.ByteString
hexSha256Hash :: ByteString -> ByteString
hexSha256Hash ByteString
dta =
  let digest :: Digest SHA256
digest = forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CT.hash ByteString
dta :: CT.Digest CT.SHA256
  in String -> ByteString
S.pack (forall a. Show a => a -> String
show Digest SHA256
digest)

hexSha256HashLazy :: L.ByteString -> S.ByteString
hexSha256HashLazy :: ByteString -> ByteString
hexSha256HashLazy ByteString
dta =
  let digest :: Digest SHA256
digest = forall a. HashAlgorithm a => ByteString -> Digest a
CT.hashlazy ByteString
dta :: CT.Digest CT.SHA256
  in String -> ByteString
S.pack (forall a. Show a => a -> String
show Digest SHA256
digest)


signRequestFull :: AWSAuthVersion -> S.ByteString -> S.ByteString -> Maybe (S.ByteString, S.ByteString) -> Request -> IO Request
signRequestFull :: AWSAuthVersion
-> ByteString
-> ByteString
-> Maybe (ByteString, ByteString)
-> Request
-> IO Request
signRequestFull AWSAuthVersion
AWSv4 = ByteString
-> ByteString
-> Maybe (ByteString, ByteString)
-> Request
-> IO Request
signRequestV4

signRequestV4 :: S.ByteString -> S.ByteString -> Maybe (S.ByteString, S.ByteString) -> Request -> IO Request
signRequestV4 :: ByteString
-> ByteString
-> Maybe (ByteString, ByteString)
-> Request
-> IO Request
signRequestV4 ByteString
key ByteString
secret Maybe (ByteString, ByteString)
serviceRegion Request
request = do
  !ByteString
ts <- IO ByteString
timestamp                         -- YYYYMMDDT242424Z, UTC based
  let origHost :: ByteString
origHost = Request
request forall s a. s -> Getting a s a -> a
^. Lens' Request ByteString
host          -- potentially w/ runscope bucket
      runscopeBucketAuth :: Maybe ByteString
runscopeBucketAuth =
        forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Runscope-Bucket-Auth" forall a b. (a -> b) -> a -> b
$ Request
request forall s a. s -> Getting a s a -> a
^. Lens' Request [(HeaderName, ByteString)]
requestHeaders
      noRunscopeHost :: ByteString
noRunscopeHost = ByteString -> ByteString
removeRunscope ByteString
origHost -- rm Runscope for signing
      (ByteString
service, ByteString
region) = case Maybe (ByteString, ByteString)
serviceRegion of
        Maybe (ByteString, ByteString)
Nothing     -> ByteString -> (ByteString, ByteString)
serviceAndRegion ByteString
noRunscopeHost
        Just (ByteString
a, ByteString
b) ->　(ByteString
a, ByteString
b)
      date :: ByteString
date = (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'T') ByteString
ts      -- YYYYMMDD
      hashedPayload :: ByteString
hashedPayload
        | Request
request forall s a. s -> Getting a s a -> a
^. Lens' Request ByteString
method forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"POST", ByteString
"PUT"] = Request -> ByteString
payloadHash Request
req
        | Bool
otherwise = ByteString -> ByteString
hexSha256Hash ByteString
""
      -- add common v4 signing headers, service specific headers, and
      -- drop tmp header and Runscope-Bucket-Auth header (if present).
      req :: Request
req = Request
request forall a b. a -> (a -> b) -> b
& Lens' Request [(HeaderName, ByteString)]
requestHeaders forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
            (([ (HeaderName
"host", ByteString
noRunscopeHost)
              , (HeaderName
"x-amz-date", ByteString
ts)] forall a. [a] -> [a] -> [a]
++
              [(HeaderName
"x-amz-content-sha256", ByteString
hashedPayload) | ByteString
service forall a. Eq a => a -> a -> Bool
== ByteString
"s3"]) forall a. [a] -> [a] -> [a]
++)
            -- Runscope (correctly) doesn't send Bucket Auth header to AWS,
            -- remove it from the headers we sign. Adding back in at the end.
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> [(a, b)]
deleteKey HeaderName
"Runscope-Bucket-Auth"
  let encodePath :: ByteString -> ByteString
encodePath ByteString
p = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"/" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ByteString -> ByteString
urlEncode Bool
False) forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
S.split Char
'/' ByteString
p
  -- task 1
  let hl :: [(HeaderName, ByteString)]
hl = Request
req forall s a. s -> Getting a s a -> a
^. Lens' Request [(HeaderName, ByteString)]
requestHeaders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Ord a => [a] -> [a]
sort
      signedHeaders :: ByteString
signedHeaders = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
";" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (HeaderName -> ByteString
lowerCI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)]
hl
      canonicalReq :: ByteString
canonicalReq = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"\n" [
          Request
req forall s a. s -> Getting a s a -> a
^. Lens' Request ByteString
method             -- step 1
        , ByteString -> ByteString
encodePath (Request
req forall s a. s -> Getting a s a -> a
^. Lens' Request ByteString
path)  -- step 2
        ,   ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"&"       -- step 3b, incl. sort
            -- urlEncode True (QS) to encode ':' and '/' (e.g. in AWS arns)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
k,ByteString
v) -> Bool -> ByteString -> ByteString
urlEncode Bool
True ByteString
k forall a. Semigroup a => a -> a -> a
<> ByteString
"=" forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString -> ByteString
urlEncode Bool
True ByteString
v)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$
          ByteString -> [(ByteString, ByteString)]
parseSimpleQuery forall a b. (a -> b) -> a -> b
$ Request
req forall s a. s -> Getting a s a -> a
^. Lens' Request ByteString
queryString
        ,   [ByteString] -> ByteString
S.unlines                -- step 4, incl. sort
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(HeaderName
k,ByteString
v) -> HeaderName -> ByteString
lowerCI HeaderName
k forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> forall {a}. a -> a
trimHeaderValue ByteString
v) forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)]
hl
        , ByteString
signedHeaders             -- step 5
        , ByteString
hashedPayload             -- step 6, handles empty payload
        ]
  -- task 2
  let dateScope :: ByteString
dateScope = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"/" [ByteString
date, ByteString
region, ByteString
service, ByteString
"aws4_request"]
      stringToSign :: ByteString
stringToSign = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"\n" [
          ByteString
"AWS4-HMAC-SHA256"
        , ByteString
ts
        , ByteString
dateScope
        , ByteString -> ByteString
hexSha256Hash ByteString
canonicalReq
        ]
  -- task 3, steps 1 and 2
  let signature :: ByteString
signature = (ByteString
"AWS4" forall a. Semigroup a => a -> a -> a
<> ByteString
secret) forall a b. a -> (a -> b) -> b
&
                  ByteString -> ByteString -> ByteString
hmac' ByteString
date forall a b. a -> (a -> b) -> b
& ByteString -> ByteString -> ByteString
hmac' ByteString
region forall a b. a -> (a -> b) -> b
& ByteString -> ByteString -> ByteString
hmac' ByteString
service forall a b. a -> (a -> b) -> b
&
                  ByteString -> ByteString -> ByteString
hmac' ByteString
"aws4_request" forall a b. a -> (a -> b) -> b
& ByteString -> ByteString -> ByteString
hmac' ByteString
stringToSign forall a b. a -> (a -> b) -> b
& ByteString -> ByteString
HEX.encode
      authorization :: ByteString
authorization = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
", " [
          ByteString
"AWS4-HMAC-SHA256 Credential=" forall a. Semigroup a => a -> a -> a
<> ByteString
key forall a. Semigroup a => a -> a -> a
<> ByteString
"/" forall a. Semigroup a => a -> a -> a
<> ByteString
dateScope
        , ByteString
"SignedHeaders=" forall a. Semigroup a => a -> a -> a
<> ByteString
signedHeaders
        , ByteString
"Signature=" forall a. Semigroup a => a -> a -> a
<> ByteString
signature
        ]
  -- Add the AWS Authorization header.
  -- Restore the Host header to the Runscope endpoint
  -- so they can proxy accordingly (if used, otherwise this is a nop).
  -- Add the Runscope Bucket Auth header back in, if it was set originally.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
setHeader HeaderName
"host" ByteString
origHost
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a -> a
id (HeaderName -> ByteString -> Request -> Request
setHeader HeaderName
"Runscope-Bucket-Auth") Maybe ByteString
runscopeBucketAuth
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> ByteString -> Request -> Request
setHeader HeaderName
"authorization" ByteString
authorization forall a b. (a -> b) -> a -> b
$ Request
req
  where
    lowerCI :: HeaderName -> ByteString
lowerCI = (Char -> Char) -> ByteString -> ByteString
S.map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. CI s -> s
CI.original
    trimHeaderValue :: a -> a
trimHeaderValue =
      forall {a}. a -> a
id -- FIXME, see step 4, whitespace trimming but not in double
         -- quoted sections, AWS spec.
    timestamp :: IO ByteString
timestamp = UTCTime -> ByteString
render forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
      where render :: UTCTime -> ByteString
render = String -> ByteString
S.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%dT%H%M%SZ" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                     TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc -- UTC printable: YYYYMMDDTHHMMSSZ
    hmac' :: S.ByteString -> S.ByteString -> S.ByteString
    hmac' :: ByteString -> ByteString -> ByteString
hmac' ByteString
s ByteString
k = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (forall a. HMAC a -> Digest a
hmacGetDigest HMAC SHA256
h)
      where h :: HMAC SHA256
h = forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
k ByteString
s :: (HMAC CT.SHA256)

payloadHash :: Request -> S.ByteString
payloadHash :: Request -> ByteString
payloadHash Request
req =
  case Request -> RequestBody
HTTP.requestBody Request
req of
    HTTP.RequestBodyBS ByteString
bs ->   ByteString -> ByteString
hexSha256Hash ByteString
bs
    HTTP.RequestBodyLBS ByteString
lbs -> ByteString -> ByteString
hexSha256HashLazy ByteString
lbs
    RequestBody
_ -> forall a. HasCallStack => String -> a
error String
"addTmpPayloadHashHeader: unexpected request body type"

-- Per AWS documentation at:
--   http://docs.aws.amazon.com/general/latest/gr/rande.html
-- For example: "dynamodb.us-east-1.amazonaws.com" -> ("dynamodb", "us-east-1")
serviceAndRegion :: S.ByteString -> (S.ByteString, S.ByteString)
serviceAndRegion :: ByteString -> (ByteString, ByteString)
serviceAndRegion ByteString
endpoint
  -- For s3, check <bucket>.s3..., i.e. virtual-host style access
  | ByteString
".s3.amazonaws.com" ByteString -> ByteString -> Bool
`S.isSuffixOf` ByteString
endpoint = -- vhost style, classic
    (ByteString
"s3", ByteString
"us-east-1")
  | ByteString
".s3-external-1.amazonaws.com" ByteString -> ByteString -> Bool
`S.isSuffixOf` ByteString
endpoint =
    (ByteString
"s3", ByteString
"us-east-1")
  | ByteString
".s3-" ByteString -> ByteString -> Bool
`S.isInfixOf` ByteString
endpoint = -- vhost style, regional
    (ByteString
"s3", ByteString -> ByteString
regionInS3VHost ByteString
endpoint)
  -- For s3, use /<bucket> style access, as opposed to
  -- <bucket>.s3... in the hostname.
  | ByteString
endpoint forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"s3.amazonaws.com", ByteString
"s3-external-1.amazonaws.com"] =
    (ByteString
"s3", ByteString
"us-east-1")
  | Char -> ByteString -> ByteString
servicePrefix Char
'-' ByteString
endpoint forall a. Eq a => a -> a -> Bool
== ByteString
"s3" =
    -- format: e.g. s3-us-west-2.amazonaws.com
    let region :: ByteString
region = (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.') forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
3 ByteString
endpoint -- drop "s3-"
    in (ByteString
"s3", ByteString
region)
    -- not s3
  | ByteString
endpoint forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"sts.amazonaws.com"] =
    (ByteString
"sts", ByteString
"us-east-1")
  | ByteString
".execute-api." ByteString -> ByteString -> Bool
`S.isInfixOf` ByteString
endpoint =
    let ByteString
gateway:ByteString
service:ByteString
region:[ByteString]
_ = Char -> ByteString -> [ByteString]
S.split Char
'.' ByteString
endpoint
    in (ByteString
service, ByteString
region)
  | ByteString
".es.amazonaws.com" ByteString -> ByteString -> Bool
`S.isSuffixOf` ByteString
endpoint =
    let ByteString
_:ByteString
region:[ByteString]
_ = Char -> ByteString -> [ByteString]
S.split Char
'.' ByteString
endpoint
    in (ByteString
"es", ByteString
region)
  | ByteString
svc forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet ByteString
noRegion =
    (ByteString
svc, ByteString
"us-east-1")
  | Bool
otherwise =
    let ByteString
service:ByteString
region:[ByteString]
_ = Char -> ByteString -> [ByteString]
S.split Char
'.' ByteString
endpoint
    in (ByteString
service, ByteString
region)
  where
    svc :: ByteString
svc = Char -> ByteString -> ByteString
servicePrefix Char
'.' ByteString
endpoint
    servicePrefix :: Char -> ByteString -> ByteString
servicePrefix Char
c = (Char -> Char) -> ByteString -> ByteString
S.map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
c)
    regionInS3VHost :: ByteString -> ByteString
regionInS3VHost ByteString
s =
        (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.') -- "eu-west-1"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse            -- "eu-west-1.amazonaws.com"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst                  -- "moc.swanozama.1-tsew-ue"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring (String -> ByteString
S.pack String
"-3s.")
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse
      forall a b. (a -> b) -> a -> b
$ ByteString
s                  -- johnsmith.eu.s3-eu-west-1.amazonaws.com
    noRegion :: HashSet ByteString
noRegion = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [ByteString
"iam", ByteString
"importexport", ByteString
"route53", ByteString
"cloudfront"]

-- If the hostname doesn't end in runscope.net, return the original.
-- For a hostname that includes runscope.net:
-- given  sqs-us--east--1-amazonaws-com-<BUCKET>.runscope.net
-- return sqs.us-east-1.amazonaws.com
removeRunscope :: S.ByteString -> S.ByteString
removeRunscope :: ByteString -> ByteString
removeRunscope ByteString
hostname
  | ByteString
".runscope.net" ByteString -> ByteString -> Bool
`S.isSuffixOf` ByteString
hostname =
    [ByteString] -> ByteString
S.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
Prelude.map (forall {a}. (Eq a, IsString a) => a -> a
p2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Eq a, IsString a) => a -> a
p1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S.group -- decode
    -- drop suffix "-<BUCKET>.runscope.net" before decoding
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ByteString -> ByteString
S.tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-') forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse
    forall a b. (a -> b) -> a -> b
$ ByteString
hostname
  | Bool
otherwise = ByteString
hostname
    where p1 :: a -> a
p1 a
"-"   = a
"."
          p1 a
other = a
other
          p2 :: a -> a
p2 a
"--"  = a
"-"
          p2 a
other = a
other