module Network.AWS.Signing.V4
(
V4
, Meta (..)
, authorisation
, module Network.AWS.Signing.Internal
) where
import Control.Applicative
import Control.Lens
import Crypto.Hash (digestToHexByteString)
import qualified Crypto.Hash.SHA256 as SHA256
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI
import Data.Default.Class
import qualified Data.Foldable as Fold
import Data.Function
import Data.List (groupBy, intersperse, sortBy, sort)
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Time
import Network.AWS.Data
import Network.AWS.Request.Internal
import Network.AWS.Signing.Internal
import Network.AWS.Types
import Network.HTTP.Types.Header
import System.Locale
data V4
data instance Meta V4 = Meta
{ _mAlgorithm :: ByteString
, _mScope :: ByteString
, _mSigned :: ByteString
, _mCReq :: ByteString
, _mSTS :: ByteString
, _mSignature :: ByteString
, _mTime :: UTCTime
}
instance Show (Meta V4) where
show Meta{..} = BS.unpack $ BS.unlines
[ "Version 4 Metadata:"
, "_mAlgorithm " <> _mAlgorithm
, "_mScope " <> _mScope
, "_mSigned " <> _mSigned
, "_mCReq " <> _mCReq
, "_mSTS " <> _mSTS
, "_mSignature " <> _mSignature
, "_mTime " <> toBS _mTime
]
instance AWSPresigner V4 where
presigned a r rq l t x = out
& sgRequest . queryString <>~ auth (out ^. sgMeta)
where
out = finalise Nothing qry service a r rq l t
qry cs sh =
pair (CI.original hAMZAlgorithm) algorithm
. pair (CI.original hAMZCredential) cs
. pair (CI.original hAMZDate) (LocaleTime l t :: ISO8601)
. pair (CI.original hAMZExpires) (LocaleTime l x :: ISO8601)
. pair (CI.original hAMZSignedHeaders) sh
. pair (CI.original hAMZToken) (toBS <$> _authToken a)
. pair (CI.original hAMZContentSHA256) ("UNSIGNED-PAYLOAD" :: ByteString)
auth = mappend "&X-AMZ-Signature=" . _mSignature
instance AWSSigner V4 where
signed a r rq l t = out
& sgRequest
%~ requestHeaders
%~ hdr hAuthorization (authorisation $ out ^. sgMeta)
where
out = finalise (Just "AWS4") (\_ _ -> id) service a r inp l t
inp = rq & rqHeaders %~ hdrs (maybeToList tok)
tok = (hAMZToken,) . toBS <$> _authToken a
authorisation :: Meta V4 -> ByteString
authorisation Meta{..} = BS.concat
[ _mAlgorithm
, " Credential="
, _mScope
, ", SignedHeaders="
, _mSigned
, ", Signature="
, _mSignature
]
algorithm :: ByteString
algorithm = "AWS4-HMAC-SHA256"
finalise :: Maybe ByteString
-> (ByteString -> ByteString -> Query -> Query)
-> Service (Sv a)
-> AuthEnv
-> Region
-> Request a
-> TimeLocale
-> UTCTime
-> Signed a V4
finalise p qry s@Service{..} AuthEnv{..} r Request{..} l t = Signed meta rq
where
meta = Meta
{ _mAlgorithm = algorithm
, _mCReq = canonicalRequest
, _mScope = toBS _authAccess <> "/" <> credentialScope
, _mSigned = signedHeaders
, _mSTS = stringToSign
, _mSignature = signature
, _mTime = t
}
rq = clientRequest
& method .~ meth
& host .~ host'
& path .~ _rqPath
& queryString .~ toBS query
& requestHeaders .~ headers
& requestBody .~ _bdyBody _rqBody
meth = toBS _rqMethod
host' = toBS (endpoint s r)
query = qry credentialScope signedHeaders _rqQuery
region | isGlobal s = def
| otherwise = r
canonicalQuery = toBS $ query
& valuesOf %~ Just . maybe "" (encodeURI True)
& keysOf %~ encodeURI False
headers = sortBy (comparing fst)
. hdr hHost host'
. hdr hAMZDate (toBS (LocaleTime l t :: AWSTime))
$ _rqHeaders
joinedHeaders = map f $ groupBy ((==) `on` fst) headers
where
f [] = ("", "")
f (h:hs) = (fst h, g $ h : hs)
g = BS.intercalate "," . sort . map snd
signedHeaders = mconcat
. intersperse ";"
$ map (CI.foldedCase . fst) joinedHeaders
canonicalHeaders = Fold.foldMap f joinedHeaders
where
f (k, v) = CI.foldedCase k
<> ":"
<> stripBS v
<> "\n"
canonicalRequest = mconcat $ intersperse "\n"
[ meth
, collapseURI (encodeURI False _rqPath)
, canonicalQuery
, canonicalHeaders
, signedHeaders
, bodyHash _rqBody
]
scope =
[ toBS (LocaleTime l t :: BasicTime)
, toBS region
, toBS _svcPrefix
, "aws4_request"
]
credentialScope = BS.intercalate "/" scope
signingKey = Fold.foldl1 hmacSHA256 $
maybe (toBS _authSecret) (<> toBS _authSecret) p : scope
stringToSign = BS.intercalate "\n"
[ algorithm
, toBS (LocaleTime l t :: AWSTime)
, credentialScope
, Base16.encode (SHA256.hash canonicalRequest)
]
signature = Base16.encode (hmacSHA256 signingKey stringToSign)