module Network.Wai.Middleware.HmacAuth.Client
(
applyHmacAuth
, defaultHmacAuthSettings
, HmacAuthSettings (..)
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Hash
import Crypto.Hash.MD5 as MD5
import Data.Byteable (toBytes)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as BS64
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as B
import Data.CaseInsensitive (CI)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Time
import Network.HTTP.Client
import qualified Network.HTTP.Types as Http
import System.Locale
data HmacAuthSettings alg = HmacAuthSettings
{
authKeyHeader :: !(CI ByteString)
, authTimestampHeader :: !(CI ByteString)
, authAlgorithm :: alg
, authRealm :: !ByteString
, authSpec :: !Strategy
}
data Strategy = Header
type Secret = ByteString
type Key = ByteString
defaultHmacAuthSettings :: HmacAuthSettings SHA512
defaultHmacAuthSettings = HmacAuthSettings
{ authRealm = "Hmac"
, authKeyHeader = "X-auth-key"
, authTimestampHeader = "X-auth-timestamp"
, authSpec = Header
, authAlgorithm = SHA512
}
applyHmacAuth :: forall m alg .
(
MonadIO m
, HashAlgorithm alg )
=> HmacAuthSettings alg
-> Key
-> Secret
-> Request
-> m Request
applyHmacAuth cfg@HmacAuthSettings{..} key secret req = do
now <- liftIO getCurrentTime
let date = timefmt now
contentmd5 = MD5.hash $ B.toStrict body
res = canonicalizedResource req
payload = buildMessage verb contentmd5 (ctype req) date res
HMAC hashed = signPayload secret payload
digest = BS64.encode (toBytes hashed)
return $ req { requestHeaders =
[ (authTimestampHeader, date)
, (authKeyHeader, key)
, authHeader cfg key digest
] <> requestHeaders req
}
where
signPayload :: Secret -> ByteString -> HMAC alg
signPayload = hmac
timefmt = BS.pack . formatTime defaultTimeLocale "%FT%T"
verb = method req
ctype = fromMaybe "" . lookup Http.hContentType . requestHeaders
body = case requestBody req of
RequestBodyLBS lbs -> lbs
RequestBodyBS bs -> B.fromStrict bs
_ -> error "RequestBody type Not Supported"
authHeader :: HmacAuthSettings alg
-> Key
-> Secret
-> (CI ByteString, ByteString)
authHeader HmacAuthSettings{..} key sig =
let auth = BS.concat [ authRealm, " ", key, ":", sig ]
in ("Authorization", auth)
buildMessage
:: Http.Method
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
buildMessage verb contentmd5 ctype date resource =
BS.concat [ verb, "\n"
, contentmd5, "\n"
, ctype, "\n"
, date, "\n"
, resource
]
canonicalizedResource :: Request -> ByteString
canonicalizedResource = path