module Network.Wai.Middleware.HmacAuth (
hmacAuth
, signRequest
, HashAlgorithm
, SHA512, SHA256, SHA1, MD5
, HmacAuthSettings (..)
, HmacStrategy (..)
, defaultHmacAuthSettings
, Secret (..)
, Key (..)
) where
import Control.Monad (when)
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 as BS
import qualified Data.ByteString.Base64 as BS64
import Data.CaseInsensitive (CI)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Word8 (isSpace, toLower, _colon)
import qualified Network.HTTP.Types as Http
import Network.Wai
data HmacAuthSettings alg = HmacAuthSettings
{
authKeyHeader :: !(CI ByteString)
, authTimestampHeader :: !(CI ByteString)
, authIsProtected :: !(Request -> IO Bool)
, authOnNoAuth :: !(HmacAuthException -> Application)
, authAlgorithm :: alg
, authRealm :: !ByteString
, authSpec :: !HmacStrategy
, authDebug :: !Bool
}
newtype Key = Key ByteString
deriving (Eq, Show)
newtype Secret = Secret ByteString
deriving (Eq, Show)
data HmacStrategy = Header
deriving Show
data HmacAuthException
= NoSecret
| NoAuthHeader
| InvalidSignature
| SignatureMismatch
deriving Show
type LookupSecret m = Key -> m (Maybe Secret)
hmacAuth :: forall alg .
HashAlgorithm alg
=> LookupSecret IO
-> HmacAuthSettings alg
-> Middleware
hmacAuth lookupSecret cfg@HmacAuthSettings {..} app req respond = do
isProtected <- authIsProtected req
allowed <- if isProtected
then check
else return $ Right ()
case allowed of
Left e -> authOnNoAuth e req respond
Right _ -> app req respond
where
check =
case lookup "Authorization" $ requestHeaders req of
Nothing -> return $ Left NoAuthHeader
Just bs ->
let (d, rest) = BS.break isSpace bs
isColon = (==) _colon
(key, signature) = BS.break isColon rest
in if BS.map toLower d == BS.map toLower authRealm
then checkB64 key signature
else return $ Left InvalidSignature
checkB64 key sig' = case BS.uncons sig' of
Nothing -> return $ Left InvalidSignature
Just (_, signature) -> do
moursecret <- lookupSecret $ Key $ BS.tail key
case moursecret of
Nothing -> return $ Left NoSecret
Just oursecret -> do
ourreq <- signRequest cfg oursecret req
let headers = requestHeaders ourreq
oursig = getBase64DecodedSignature cfg authRealm headers
when authDebug $ sequence_
[
print ("Server Key: " <> show key)
, print ("Server Sig: " <> show oursig)
, print ("Client Sig: " <> show signature)
]
case oursig of
Left e -> return $ Left e
Right sig -> return $ checkSig sig signature
checkSig oursig theirsig = if oursig == theirsig
then Right ()
else Left SignatureMismatch
defaultHmacAuthSettings :: HmacAuthSettings SHA512
defaultHmacAuthSettings = HmacAuthSettings
{ authRealm = "Hmac"
, authKeyHeader = "X-auth-key"
, authTimestampHeader = "X-auth-timestamp"
, authOnNoAuth = defUnauthorized
, authIsProtected = const $ return True
, authSpec = Header
, authAlgorithm = SHA512
, authDebug = True
}
where
defNoAuthHeader =
("WWW-Authenticate", BS.concat
[ "Realm=\"\" "
, "HMAC-MD5;HMAC-SHA1;HMAC-SHA256;HMAC-SHA512"
])
defUnauthorized _ _req f = f $ responseLBS
Http.status401
(defNoAuthHeader : requestHeaders _req)
"Provide valid credentials"
getBase64DecodedSignature
:: HmacAuthSettings alg
-> ByteString
-> [(CI ByteString, ByteString)]
-> Either HmacAuthException ByteString
getBase64DecodedSignature HmacAuthSettings{..} realm headers =
case lookup "Authorization" headers of
Nothing -> Left InvalidSignature
Just bs ->
let (r, rest) = BS.break isSpace bs
isColon = (==) _colon
(_, sig') = BS.break isColon rest
in if BS.map toLower r == BS.map toLower realm
then case BS.uncons sig' of
Nothing -> Left InvalidSignature
Just (_, sig'') -> Right sig''
else Left InvalidSignature
signRequest :: forall m alg .
(
MonadIO m
, HashAlgorithm alg )
=> HmacAuthSettings alg
-> Secret
-> Request
-> m Request
signRequest cfg@HmacAuthSettings{..} (Secret secret) req = do
body <- liftIO $ requestBody req
let contentmd5 = MD5.hash body
res = canonicalizedResource req
payload = buildMessage verb contentmd5 ctype date res
HMAC hashed = hmac secret payload :: HMAC alg
digest = BS64.encode (toBytes hashed)
return $ req { requestHeaders =
authHeader cfg (Key key) (Secret digest)
: requestHeaders req
}
where
maybeHeader = fromMaybe "" . flip lookup (requestHeaders req)
verb = requestMethod req
ctype = maybeHeader Http.hContentType
date = maybeHeader authTimestampHeader
key = maybeHeader authKeyHeader
authHeader :: HmacAuthSettings alg
-> Key
-> Secret
-> (CI ByteString, ByteString)
authHeader HmacAuthSettings{..} (Key key) (Secret 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 = rawPathInfo