module Network.Wreq.Internal.AWS
(
signRequest
) 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
signRequest :: AWSAuthVersion -> S.ByteString -> S.ByteString ->
Request -> IO Request
signRequest AWSv4 = signRequestV4
hexSha256Hash :: S.ByteString -> S.ByteString
hexSha256Hash dta =
let digest = CT.hash dta :: CT.Digest CT.SHA256
in S.pack (show digest)
hexSha256HashLazy :: L.ByteString -> S.ByteString
hexSha256HashLazy dta =
let digest = CT.hashlazy dta :: CT.Digest CT.SHA256
in S.pack (show digest)
signRequestV4 :: S.ByteString -> S.ByteString -> Request -> IO Request
signRequestV4 key secret request = do
!ts <- timestamp
let origHost = request ^. host
runscopeBucketAuth =
lookup "Runscope-Bucket-Auth" $ request ^. requestHeaders
noRunscopeHost = removeRunscope origHost
(service, region) = serviceAndRegion noRunscopeHost
date = S.takeWhile (/= 'T') ts
hashedPayload
| request ^. method `elem` ["POST", "PUT"] = payloadHash req
| otherwise = hexSha256Hash ""
req = request & requestHeaders %~
(([ ("host", noRunscopeHost)
, ("x-amz-date", ts)] ++
[("x-amz-content-sha256", hashedPayload) | service == "s3"]) ++)
. deleteKey "Runscope-Bucket-Auth"
let hl = req ^. requestHeaders . to sort
signedHeaders = S.intercalate ";" . map (lowerCI . fst) $ hl
canonicalReq = S.intercalate "\n" [
req ^. method
, req ^. path
, S.intercalate "&"
. map (\(k,v) -> urlEncode True k <> "=" <> urlEncode True v)
. sort $
parseSimpleQuery $ req ^. queryString
, S.unlines
. map (\(k,v) -> lowerCI k <> ":" <> trimHeaderValue v) $ hl
, signedHeaders
, hashedPayload
]
let dateScope = S.intercalate "/" [date, region, service, "aws4_request"]
stringToSign = S.intercalate "\n" [
"AWS4-HMAC-SHA256"
, ts
, dateScope
, hexSha256Hash canonicalReq
]
let signature = ("AWS4" <> secret) &
hmac' date & hmac' region & hmac' service &
hmac' "aws4_request" & hmac' stringToSign & HEX.encode
authorization = S.intercalate ", " [
"AWS4-HMAC-SHA256 Credential=" <> key <> "/" <> dateScope
, "SignedHeaders=" <> signedHeaders
, "Signature=" <> signature
]
return $ setHeader "host" origHost
<$> maybe id (setHeader "Runscope-Bucket-Auth") runscopeBucketAuth
<$> setHeader "authorization" authorization $ req
where
lowerCI = S.map toLower . CI.original
trimHeaderValue =
id
timestamp = render <$> getCurrentTime
where render = S.pack . formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" .
utcToLocalTime utc
hmac' :: S.ByteString -> S.ByteString -> S.ByteString
hmac' s k = convert (hmacGetDigest h)
where h = hmac k s :: (HMAC CT.SHA256)
payloadHash :: Request -> S.ByteString
payloadHash req =
case HTTP.requestBody req of
HTTP.RequestBodyBS bs -> hexSha256Hash bs
HTTP.RequestBodyLBS lbs -> hexSha256HashLazy lbs
_ -> error "addTmpPayloadHashHeader: unexpected request body type"
serviceAndRegion :: S.ByteString -> (S.ByteString, S.ByteString)
serviceAndRegion endpoint
| ".s3.amazonaws.com" `S.isSuffixOf` endpoint =
("s3", "us-east-1")
| ".s3-external-1.amazonaws.com" `S.isSuffixOf` endpoint =
("s3", "us-east-1")
| ".s3-" `S.isInfixOf` endpoint =
("s3", regionInS3VHost endpoint)
| endpoint `elem` ["s3.amazonaws.com", "s3-external-1.amazonaws.com"] =
("s3", "us-east-1")
| servicePrefix '-' endpoint == "s3" =
let region = S.takeWhile (/= '.') $ S.drop 3 endpoint
in ("s3", region)
| endpoint `elem` ["sts.amazonaws.com"] =
("sts", "us-east-1")
| svc `HashSet.member` noRegion =
(svc, "us-east-1")
| otherwise =
let service:region:_ = S.split '.' endpoint
in (service, region)
where
svc = servicePrefix '.' endpoint
servicePrefix c = S.map toLower . S.takeWhile (/= c)
regionInS3VHost s =
S.takeWhile (/= '.')
. S.reverse
. fst
. S.breakSubstring (S.pack "-3s.")
. S.reverse
$ s
noRegion = HashSet.fromList ["iam", "importexport", "route53", "cloudfront"]
removeRunscope :: S.ByteString -> S.ByteString
removeRunscope hostname
| ".runscope.net" `S.isSuffixOf` hostname =
S.concat . Prelude.map (p2 . p1) . S.group
. S.reverse . S.tail . S.dropWhile (/= '-') . S.reverse
$ hostname
| otherwise = hostname
where p1 "-" = "."
p1 other = other
p2 "--" = "-"
p2 other = other