{-# 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 Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing Request
r

hexSha256Hash :: S.ByteString -> S.ByteString
hexSha256Hash :: ByteString -> ByteString
hexSha256Hash ByteString
dta =
  let digest :: Digest SHA256
digest = ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CT.hash ByteString
dta :: CT.Digest CT.SHA256
  in String -> ByteString
S.pack (Digest SHA256 -> String
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 = ByteString -> Digest SHA256
forall a. HashAlgorithm a => ByteString -> Digest a
CT.hashlazy ByteString
dta :: CT.Digest CT.SHA256
  in String -> ByteString
S.pack (Digest SHA256 -> String
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 Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
Lens' Request ByteString
host          -- potentially w/ runscope bucket
      runscopeBucketAuth :: Maybe ByteString
runscopeBucketAuth =
        HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Runscope-Bucket-Auth" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request
request Request
-> Getting
     [(HeaderName, ByteString)] Request [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
forall s a. s -> Getting a s a -> a
^. Getting
  [(HeaderName, ByteString)] Request [(HeaderName, ByteString)]
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'T') ByteString
ts      -- YYYYMMDD
      hashedPayload :: ByteString
hashedPayload
        | Request
request Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
Lens' Request ByteString
method ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ([(HeaderName, ByteString)] -> Identity [(HeaderName, ByteString)])
-> Request -> Identity Request
Lens' Request [(HeaderName, ByteString)]
requestHeaders (([(HeaderName, ByteString)]
  -> Identity [(HeaderName, ByteString)])
 -> Request -> Identity Request)
-> ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> Request
-> Request
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
            (([ (HeaderName
"host", ByteString
noRunscopeHost)
              , (HeaderName
"x-amz-date", ByteString
ts)] [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. [a] -> [a] -> [a]
++
              [(HeaderName
"x-amz-content-sha256", ByteString
hashedPayload) | ByteString
service ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"s3"]) [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
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.
            ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
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
"/" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ByteString -> ByteString
urlEncode Bool
False) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
S.split Char
'/' ByteString
p
  -- task 1
  let hl :: [(HeaderName, ByteString)]
hl = Request
req Request
-> Getting
     [(HeaderName, ByteString)] Request [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
forall s a. s -> Getting a s a -> a
^. Getting
  [(HeaderName, ByteString)] Request [(HeaderName, ByteString)]
Lens' Request [(HeaderName, ByteString)]
requestHeaders Getting
  [(HeaderName, ByteString)] Request [(HeaderName, ByteString)]
-> (([(HeaderName, ByteString)]
     -> Const [(HeaderName, ByteString)] [(HeaderName, ByteString)])
    -> [(HeaderName, ByteString)]
    -> Const [(HeaderName, ByteString)] [(HeaderName, ByteString)])
-> Getting
     [(HeaderName, ByteString)] Request [(HeaderName, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> ([(HeaderName, ByteString)]
    -> Const [(HeaderName, ByteString)] [(HeaderName, ByteString)])
-> [(HeaderName, ByteString)]
-> Const [(HeaderName, ByteString)] [(HeaderName, ByteString)]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. Ord a => [a] -> [a]
sort
      signedHeaders :: ByteString
signedHeaders = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
";" ([ByteString] -> ByteString)
-> ([(HeaderName, ByteString)] -> [ByteString])
-> [(HeaderName, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> ByteString)
-> [(HeaderName, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName -> ByteString
lowerCI (HeaderName -> ByteString)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) ([(HeaderName, ByteString)] -> ByteString)
-> [(HeaderName, ByteString)] -> ByteString
forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)]
hl
      canonicalReq :: ByteString
canonicalReq = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"\n" [
          Request
req Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
Lens' Request ByteString
method             -- step 1
        , ByteString -> ByteString
encodePath (Request
req Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
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)
          ([ByteString] -> ByteString)
-> ([(ByteString, ByteString)] -> [ByteString])
-> [(ByteString, ByteString)]
-> 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
k,ByteString
v) -> Bool -> ByteString -> ByteString
urlEncode Bool
True ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString -> ByteString
urlEncode Bool
True ByteString
v)
          ([(ByteString, ByteString)] -> [ByteString])
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Ord a => [a] -> [a]
sort ([(ByteString, ByteString)] -> ByteString)
-> [(ByteString, ByteString)] -> ByteString
forall a b. (a -> b) -> a -> b
$
          ByteString -> [(ByteString, ByteString)]
parseSimpleQuery (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request
req Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
Lens' Request ByteString
queryString
        ,   [ByteString] -> ByteString
S.unlines                -- step 4, incl. sort
          ([ByteString] -> ByteString)
-> ([(HeaderName, ByteString)] -> [ByteString])
-> [(HeaderName, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> ByteString)
-> [(HeaderName, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\(HeaderName
k,ByteString
v) -> HeaderName -> ByteString
lowerCI HeaderName
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
forall {a}. a -> a
trimHeaderValue ByteString
v) ([(HeaderName, ByteString)] -> ByteString)
-> [(HeaderName, ByteString)] -> ByteString
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" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
secret) ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
&
                  ByteString -> ByteString -> ByteString
hmac' ByteString
date ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> ByteString -> ByteString
hmac' ByteString
region ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> ByteString -> ByteString
hmac' ByteString
service ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
&
                  ByteString -> ByteString -> ByteString
hmac' ByteString
"aws4_request" ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> ByteString -> ByteString
hmac' ByteString
stringToSign ByteString -> (ByteString -> ByteString) -> ByteString
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=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
dateScope
        , ByteString
"SignedHeaders=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
signedHeaders
        , ByteString
"Signature=" ByteString -> ByteString -> ByteString
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.
  Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
setHeader HeaderName
"host" ByteString
origHost
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Request -> Request)
-> (ByteString -> Request -> Request)
-> Maybe ByteString
-> Request
-> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall {a}. a -> a
id (HeaderName -> ByteString -> Request -> Request
setHeader HeaderName
"Runscope-Bucket-Auth") Maybe ByteString
runscopeBucketAuth
        (Request -> Request) -> (Request -> Request) -> Request -> Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> ByteString -> Request -> Request
setHeader HeaderName
"authorization" ByteString
authorization (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
req
  where
    lowerCI :: HeaderName -> ByteString
lowerCI = (Char -> Char) -> ByteString -> ByteString
S.map Char -> Char
toLower (ByteString -> ByteString)
-> (HeaderName -> ByteString) -> HeaderName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
forall s. CI s -> s
CI.original
    trimHeaderValue :: a -> a
trimHeaderValue =
      a -> a
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 (UTCTime -> ByteString) -> IO UTCTime -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
      where render :: UTCTime -> ByteString
render = String -> ByteString
S.pack (String -> ByteString)
-> (UTCTime -> String) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%dT%H%M%SZ" (LocalTime -> String)
-> (UTCTime -> LocalTime) -> UTCTime -> String
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 = Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (HMAC SHA256 -> Digest SHA256
forall a. HMAC a -> Digest a
hmacGetDigest HMAC SHA256
h)
      where h :: HMAC SHA256
h = ByteString -> ByteString -> HMAC SHA256
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
_ -> String -> ByteString
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 ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 ByteString -> ByteString -> Bool
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (ByteString -> ByteString) -> ByteString -> ByteString
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 ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 ByteString -> HashSet ByteString -> Bool
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 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c)
    regionInS3VHost :: ByteString -> ByteString
regionInS3VHost ByteString
s =
        (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') -- "eu-west-1"
      (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse            -- "eu-west-1.amazonaws.com"
      (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst                  -- "moc.swanozama.1-tsew-ue"
      ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring (String -> ByteString
S.pack String
"-3s.")
      (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse
      (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
s                  -- johnsmith.eu.s3-eu-west-1.amazonaws.com
    noRegion :: HashSet ByteString
noRegion = [ByteString] -> HashSet ByteString
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 ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (ByteString -> ByteString
forall {a}. (Eq a, IsString a) => a -> a
p2 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall {a}. (Eq a, IsString a) => a -> a
p1) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S.group -- decode
    -- drop suffix "-<BUCKET>.runscope.net" before decoding
    (ByteString -> [ByteString])
-> (ByteString -> ByteString) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.tail (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
S.reverse
    (ByteString -> ByteString) -> ByteString -> ByteString
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