From ffab8a106af453a212716ba0a40a7ea0f73b6d07 Mon Sep 17 00:00:00 2001 From: Adlai Arnold Date: Wed, 1 Jun 2022 12:48:44 -0700 Subject: [PATCH 1/5] user can now specify signature auth header name --- src/Servant/Auth/Hmac/Client.hs | 20 +++++++++++++------- src/Servant/Auth/Hmac/Crypto.hs | 31 ++++++++++++++----------------- src/Servant/Auth/Hmac/Server.hs | 23 +++++++++++++++-------- test/Servant/Auth/HmacSpec.hs | 2 +- 4 files changed, 43 insertions(+), 33 deletions(-) diff --git a/src/Servant/Auth/Hmac/Client.hs b/src/Servant/Auth/Hmac/Client.hs index fe6ab53..df671d9 100644 --- a/src/Servant/Auth/Hmac/Client.hs +++ b/src/Servant/Auth/Hmac/Client.hs @@ -41,7 +41,6 @@ import Servant.Auth.Hmac.Crypto ( RequestPayload (..), SecretKey, Signature (..), - authHeaderName, keepWhitelistedHeaders, requestSignature, signSHA256, @@ -49,6 +48,7 @@ import Servant.Auth.Hmac.Crypto ( import qualified Network.HTTP.Client as Client import qualified Servant.Client.Core as Servant +import Network.HTTP.Types -- | Environment for 'HmacClientM'. Contains all required settings for hmac client. data HmacSettings = HmacSettings @@ -59,6 +59,8 @@ data HmacSettings = HmacSettings , hmacRequestHook :: Maybe (Servant.Request -> ClientM ()) -- ^ Function to call for every request after this request is signed. -- Useful for debugging. + , hmacAuthHeaderName :: HeaderName + -- ^ Header name to use to get request signature } {- | Default 'HmacSettings' with the following configuration: @@ -66,6 +68,7 @@ data HmacSettings = HmacSettings 1. Signing function is 'signSHA256'. 2. Secret key is provided. 3. 'hmacRequestHook' is 'Nothing'. +4. 'hmacAuthHeaderName' is 'Authentication'. -} defaultHmacSettings :: SecretKey -> HmacSettings defaultHmacSettings sk = @@ -73,6 +76,7 @@ defaultHmacSettings sk = { hmacSigner = signSHA256 , hmacSecretKey = sk , hmacRequestHook = Nothing + , hmacAuthHeaderName = "Authentication" } {- | @newtype@ wrapper over 'ClientM' that signs all outgoing requests @@ -90,7 +94,7 @@ hmacClientSign :: Servant.Request -> HmacClientM Servant.Request hmacClientSign req = HmacClientM $ do HmacSettings{..} <- ask url <- lift $ asks baseUrl - let signedRequest = signRequestHmac hmacSigner hmacSecretKey url req + let signedRequest = signRequestHmac hmacAuthHeaderName hmacSigner hmacSecretKey url req case hmacRequestHook of Nothing -> pure () Just hook -> lift $ hook signedRequest @@ -118,13 +122,13 @@ hmacClient = Proxy @api `clientIn` Proxy @HmacClientM -- Internals ---------------------------------------------------------------------------- -servantRequestToPayload :: BaseUrl -> Servant.Request -> RequestPayload -servantRequestToPayload url sreq = +servantRequestToPayload :: HeaderName -> BaseUrl -> Servant.Request -> RequestPayload +servantRequestToPayload authHeaderName url sreq = RequestPayload { rpMethod = Client.method req , rpContent = "" -- toBsBody $ Client.requestBody req , rpHeaders = - keepWhitelistedHeaders $ + keepWhitelistedHeaders authHeaderName $ ("Host", hostAndPort) : ("Accept-Encoding", "gzip") : Client.requestHeaders req @@ -162,6 +166,8 @@ Authentication: HMAC @ -} signRequestHmac :: + -- | Authentication header name + HeaderName -> -- | Signing function (SecretKey -> ByteString -> Signature) -> -- | Secret key that was used for signing 'Request' @@ -172,8 +178,8 @@ signRequestHmac :: Servant.Request -> -- | Signed request Servant.Request -signRequestHmac signer sk url req = do - let payload = servantRequestToPayload url req +signRequestHmac authHeaderName signer sk url req = do + let payload = servantRequestToPayload authHeaderName url req let signature = requestSignature signer sk payload let authHead = (authHeaderName, "HMAC " <> unSignature signature) req{Servant.requestHeaders = authHead <| Servant.requestHeaders req} diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs index 801f5c9..4b3946a 100644 --- a/src/Servant/Auth/Hmac/Crypto.hs +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -14,9 +14,6 @@ module Servant.Auth.Hmac.Crypto ( verifySignatureHmac, whitelistHeaders, keepWhitelistedHeaders, - - -- * Internals - authHeaderName, ) where import Crypto.Hash (hash) @@ -24,7 +21,7 @@ import Crypto.Hash.Algorithms (MD5, SHA256) import Crypto.Hash.IO (HashAlgorithm) import Crypto.MAC.HMAC (HMAC (hmacGetDigest), hmac) import Data.ByteString (ByteString) -import Data.CaseInsensitive (foldedCase) +import Data.CaseInsensitive (foldedCase, CI (original)) import Data.List (sort, uncons) import Network.HTTP.Types (Header, HeaderName, Method, RequestHeaders) @@ -32,6 +29,7 @@ import qualified Data.ByteArray as BA (convert) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy as Lazy -- | The wraper for the secret key. newtype SecretKey = SecretKey @@ -143,20 +141,20 @@ requestSignature signer sk = signer sk . createStringToSign {- | White-listed headers. Only these headers will be taken into consideration: -1. @Authentication@ +1. An authentication header of your choosing 2. @Host@ 3. @Accept-Encoding@ -} -whitelistHeaders :: [HeaderName] -whitelistHeaders = +whitelistHeaders :: HeaderName -> [HeaderName] +whitelistHeaders authHeaderName = [ authHeaderName , "Host" , "Accept-Encoding" ] -- | Keeps only headers from 'whitelistHeaders'. -keepWhitelistedHeaders :: [Header] -> [Header] -keepWhitelistedHeaders = filter (\(name, _) -> name `elem` whitelistHeaders) +keepWhitelistedHeaders :: HeaderName -> [Header] -> [Header] +keepWhitelistedHeaders authHeaderName = filter (\(name, _) -> name `elem` whitelistHeaders authHeaderName) {- | This function takes signing function @signer@ and secret key and expects that given 'Request' has header: @@ -169,13 +167,15 @@ It checks whether @@ is true request signature. Function returns 'Not if it is true, and 'Just' error message otherwise. -} verifySignatureHmac :: + -- | Auth header name + HeaderName -> -- | Signing function (SecretKey -> ByteString -> Signature) -> -- | Secret key that was used for signing 'Request' SecretKey -> RequestPayload -> Maybe LBS.ByteString -verifySignatureHmac signer sk signedPayload = case unsignedPayload of +verifySignatureHmac authHeaderName signer sk signedPayload = case unsignedPayload of Left err -> Just err Right (pay, sig) -> if sig == requestSignature signer sk pay @@ -184,8 +184,8 @@ verifySignatureHmac signer sk signedPayload = case unsignedPayload of where -- Extracts HMAC signature from request and returns request with @authHeaderName@ header unsignedPayload :: Either LBS.ByteString (RequestPayload, Signature) - unsignedPayload = case extractOn isAuthHeader $ rpHeaders signedPayload of - (Nothing, _) -> Left "No 'Authentication' header" + unsignedPayload = case extractOn (isAuthHeader authHeaderName) $ rpHeaders signedPayload of + (Nothing, _) -> Left $ "No '" <> Lazy.fromStrict (original authHeaderName) <> "' header" (Just (_, val), headers) -> case BS.stripPrefix "HMAC " val of Just sig -> Right @@ -198,11 +198,8 @@ verifySignatureHmac signer sk signedPayload = case unsignedPayload of -- Internals ---------------------------------------------------------------------------- -authHeaderName :: HeaderName -authHeaderName = "Authentication" - -isAuthHeader :: Header -> Bool -isAuthHeader = (== authHeaderName) . fst +isAuthHeader :: HeaderName -> Header -> Bool +isAuthHeader name = (== name) . fst hashMD5 :: ByteString -> ByteString hashMD5 = BA.convert . hash @_ @MD5 diff --git a/src/Servant/Auth/Hmac/Server.hs b/src/Servant/Auth/Hmac/Server.hs index 6bb081a..6275117 100644 --- a/src/Servant/Auth/Hmac/Server.hs +++ b/src/Servant/Auth/Hmac/Server.hs @@ -30,6 +30,7 @@ import Servant.Auth.Hmac.Crypto ( ) import qualified Network.Wai as Wai (Request) +import Network.HTTP.Types type HmacAuth = AuthProtect "hmac-auth" @@ -40,21 +41,25 @@ type HmacAuthContextHandlers = '[HmacAuthHandler] type HmacAuthContext = Context HmacAuthContextHandlers hmacAuthServerContext :: + -- | Auth header name + HeaderName -> -- | Signing function (SecretKey -> ByteString -> Signature) -> -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthContext -hmacAuthServerContext signer sk = hmacAuthHandler signer sk :. EmptyContext +hmacAuthServerContext authHeaderName signer sk = hmacAuthHandler authHeaderName signer sk :. EmptyContext -- | Create 'HmacAuthHandler' from signing function and secret key. hmacAuthHandler :: + -- | Auth header name + HeaderName -> -- | Signing function (SecretKey -> ByteString -> Signature) -> -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandler = hmacAuthHandlerMap pure +hmacAuthHandler authHeaderName = hmacAuthHandlerMap authHeaderName pure {- | Like 'hmacAuthHandler' but allows to specify additional mapping function for 'Wai.Request'. This can be useful if you want to print incoming request (for @@ -62,6 +67,8 @@ logging purposes) or filter some headers (to match signature). Given function is applied before signature verification. -} hmacAuthHandlerMap :: + -- | Auth header name + HeaderName -> -- | Request mapper (Wai.Request -> Handler Wai.Request) -> -- | Signing function @@ -69,13 +76,13 @@ hmacAuthHandlerMap :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandlerMap mapper signer sk = mkAuthHandler handler +hmacAuthHandlerMap authHeaderName mapper signer sk = mkAuthHandler handler where handler :: Wai.Request -> Handler () handler req = do newReq <- mapper req - let payload = waiRequestToPayload newReq - let verification = verifySignatureHmac signer sk payload + let payload = waiRequestToPayload authHeaderName newReq + let verification = verifySignatureHmac authHeaderName signer sk payload case verification of Nothing -> pure () Just bs -> throwError $ err401{errBody = bs} @@ -93,12 +100,12 @@ hmacAuthHandlerMap mapper signer sk = mkAuthHandler handler -- then pure [] -- else (chunk:) <$> getChunks -waiRequestToPayload :: Wai.Request -> RequestPayload +waiRequestToPayload :: HeaderName -> Wai.Request -> RequestPayload -- waiRequestToPayload req = getWaiRequestBody req >>= \body -> pure RequestPayload -waiRequestToPayload req = +waiRequestToPayload authHeaderName req = RequestPayload { rpMethod = requestMethod req , rpContent = "" - , rpHeaders = keepWhitelistedHeaders $ requestHeaders req + , rpHeaders = keepWhitelistedHeaders authHeaderName $ requestHeaders req , rpRawUrl = fromMaybe mempty (requestHeaderHost req) <> rawPathInfo req <> rawQueryString req } diff --git a/test/Servant/Auth/HmacSpec.hs b/test/Servant/Auth/HmacSpec.hs index 5d97df4..7b1d097 100644 --- a/test/Servant/Auth/HmacSpec.hs +++ b/test/Servant/Auth/HmacSpec.hs @@ -77,7 +77,7 @@ securedEchoServer :: Server EchoApi securedEchoServer = const echoBack securedEchoApp :: SecretKey -> Application -securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext signSHA256 sk) securedEchoServer +securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext "Authentication" signSHA256 sk) securedEchoServer withSecuredEchoApp :: SecretKey -> (Warp.Port -> IO ()) -> IO () withSecuredEchoApp sk = Warp.testWithApplication (pure $ securedEchoApp sk) From 16dcd41c2c86ff854920a7ca0ae098851c10b233 Mon Sep 17 00:00:00 2001 From: Adlai Arnold Date: Thu, 2 Jun 2022 10:11:05 -0700 Subject: [PATCH 2/5] export default auth header variable instead of hardcoding 'Authentication' throughout code --- src/Servant/Auth/Hmac/Client.hs | 5 +++-- src/Servant/Auth/Hmac/Crypto.hs | 6 ++++++ test/Servant/Auth/HmacSpec.hs | 5 +++-- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Servant/Auth/Hmac/Client.hs b/src/Servant/Auth/Hmac/Client.hs index df671d9..0ec2ecb 100644 --- a/src/Servant/Auth/Hmac/Client.hs +++ b/src/Servant/Auth/Hmac/Client.hs @@ -43,7 +43,8 @@ import Servant.Auth.Hmac.Crypto ( Signature (..), keepWhitelistedHeaders, requestSignature, - signSHA256, + signSHA256, + defaultAuthHeaderName ) import qualified Network.HTTP.Client as Client @@ -76,7 +77,7 @@ defaultHmacSettings sk = { hmacSigner = signSHA256 , hmacSecretKey = sk , hmacRequestHook = Nothing - , hmacAuthHeaderName = "Authentication" + , hmacAuthHeaderName = defaultAuthHeaderName } {- | @newtype@ wrapper over 'ClientM' that signs all outgoing requests diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs index 4b3946a..a980736 100644 --- a/src/Servant/Auth/Hmac/Crypto.hs +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -14,6 +14,9 @@ module Servant.Auth.Hmac.Crypto ( verifySignatureHmac, whitelistHeaders, keepWhitelistedHeaders, + + -- * Internal + defaultAuthHeaderName ) where import Crypto.Hash (hash) @@ -198,6 +201,9 @@ verifySignatureHmac authHeaderName signer sk signedPayload = case unsignedPayloa -- Internals ---------------------------------------------------------------------------- +defaultAuthHeaderName :: HeaderName +defaultAuthHeaderName = "Authentication" + isAuthHeader :: HeaderName -> Header -> Bool isAuthHeader name = (== name) . fst diff --git a/test/Servant/Auth/HmacSpec.hs b/test/Servant/Auth/HmacSpec.hs index 7b1d097..910f806 100644 --- a/test/Servant/Auth/HmacSpec.hs +++ b/test/Servant/Auth/HmacSpec.hs @@ -26,7 +26,8 @@ import Servant.Auth.Hmac ( hmacAuthServerContext, hmacClient, runHmacClient, - signSHA256, + signSHA256, + defaultAuthHeaderName ) import Servant.Client ( BaseUrl (baseUrlPort), @@ -77,7 +78,7 @@ securedEchoServer :: Server EchoApi securedEchoServer = const echoBack securedEchoApp :: SecretKey -> Application -securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext "Authentication" signSHA256 sk) securedEchoServer +securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext defaultAuthHeaderName signSHA256 sk) securedEchoServer withSecuredEchoApp :: SecretKey -> (Warp.Port -> IO ()) -> IO () withSecuredEchoApp sk = Warp.testWithApplication (pure $ securedEchoApp sk) From 95a0281b45f90394169b19153d2f1c5791c339c8 Mon Sep 17 00:00:00 2001 From: Adlai Arnold Date: Thu, 2 Jun 2022 15:13:46 -0700 Subject: [PATCH 3/5] make change non-breaking by retaining old API and moving new features to functions suffixed with backtick --- src/Servant/Auth/Hmac/Client.hs | 10 ++++---- src/Servant/Auth/Hmac/Crypto.hs | 25 +++++++++++++++----- src/Servant/Auth/Hmac/Server.hs | 42 ++++++++++++++++++++++----------- test/Servant/Auth/HmacSpec.hs | 7 +++--- 4 files changed, 55 insertions(+), 29 deletions(-) diff --git a/src/Servant/Auth/Hmac/Client.hs b/src/Servant/Auth/Hmac/Client.hs index 0ec2ecb..6c3a92f 100644 --- a/src/Servant/Auth/Hmac/Client.hs +++ b/src/Servant/Auth/Hmac/Client.hs @@ -41,10 +41,9 @@ import Servant.Auth.Hmac.Crypto ( RequestPayload (..), SecretKey, Signature (..), - keepWhitelistedHeaders, requestSignature, - signSHA256, - defaultAuthHeaderName + signSHA256, + defaultAuthHeaderName, keepWhitelistedHeaders' ) import qualified Network.HTTP.Client as Client @@ -129,7 +128,7 @@ servantRequestToPayload authHeaderName url sreq = { rpMethod = Client.method req , rpContent = "" -- toBsBody $ Client.requestBody req , rpHeaders = - keepWhitelistedHeaders authHeaderName $ + keepWhitelistedHeaders' authHeaderName $ ("Host", hostAndPort) : ("Accept-Encoding", "gzip") : Client.requestHeaders req @@ -164,8 +163,9 @@ servantRequestToPayload authHeaderName url sreq = @ Authentication: HMAC -@ + -} + signRequestHmac :: -- | Authentication header name HeaderName -> diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs index a980736..ba0de7d 100644 --- a/src/Servant/Auth/Hmac/Crypto.hs +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -12,8 +12,11 @@ module Servant.Auth.Hmac.Crypto ( RequestPayload (..), requestSignature, verifySignatureHmac, + verifySignatureHmac', whitelistHeaders, + whitelistHeaders', keepWhitelistedHeaders, + keepWhitelistedHeaders', -- * Internal defaultAuthHeaderName @@ -148,16 +151,22 @@ requestSignature signer sk = signer sk . createStringToSign 2. @Host@ 3. @Accept-Encoding@ -} -whitelistHeaders :: HeaderName -> [HeaderName] -whitelistHeaders authHeaderName = +whitelistHeaders :: [HeaderName] +whitelistHeaders = whitelistHeaders' defaultAuthHeaderName + +whitelistHeaders' :: HeaderName -> [HeaderName] +whitelistHeaders' authHeaderName = [ authHeaderName , "Host" , "Accept-Encoding" ] -- | Keeps only headers from 'whitelistHeaders'. -keepWhitelistedHeaders :: HeaderName -> [Header] -> [Header] -keepWhitelistedHeaders authHeaderName = filter (\(name, _) -> name `elem` whitelistHeaders authHeaderName) +keepWhitelistedHeaders :: [Header] -> [Header] +keepWhitelistedHeaders = keepWhitelistedHeaders' defaultAuthHeaderName + +keepWhitelistedHeaders' :: HeaderName -> [Header] -> [Header] +keepWhitelistedHeaders' authHeaderName = filter (\(name, _) -> name `elem` whitelistHeaders' authHeaderName) {- | This function takes signing function @signer@ and secret key and expects that given 'Request' has header: @@ -169,7 +178,11 @@ Authentication: HMAC It checks whether @@ is true request signature. Function returns 'Nothing' if it is true, and 'Just' error message otherwise. -} -verifySignatureHmac :: + +verifySignatureHmac :: (SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Maybe Lazy.ByteString +verifySignatureHmac = verifySignatureHmac' defaultAuthHeaderName + +verifySignatureHmac' :: -- | Auth header name HeaderName -> -- | Signing function @@ -178,7 +191,7 @@ verifySignatureHmac :: SecretKey -> RequestPayload -> Maybe LBS.ByteString -verifySignatureHmac authHeaderName signer sk signedPayload = case unsignedPayload of +verifySignatureHmac' authHeaderName signer sk signedPayload = case unsignedPayload of Left err -> Just err Right (pay, sig) -> if sig == requestSignature signer sk pay diff --git a/src/Servant/Auth/Hmac/Server.hs b/src/Servant/Auth/Hmac/Server.hs index 6275117..6c9ebf1 100644 --- a/src/Servant/Auth/Hmac/Server.hs +++ b/src/Servant/Auth/Hmac/Server.hs @@ -8,8 +8,11 @@ module Servant.Auth.Hmac.Server ( HmacAuthContext, HmacAuthHandler, hmacAuthServerContext, + hmacAuthServerContext', hmacAuthHandler, + hmacAuthHandler', hmacAuthHandlerMap, + hmacAuthHandlerMap', ) where import Control.Monad.Except (throwError) @@ -24,9 +27,7 @@ import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHand import Servant.Auth.Hmac.Crypto ( RequestPayload (..), SecretKey, - Signature, - keepWhitelistedHeaders, - verifySignatureHmac, + Signature, verifySignatureHmac', keepWhitelistedHeaders', defaultAuthHeaderName ) import qualified Network.Wai as Wai (Request) @@ -40,7 +41,10 @@ type HmacAuthHandler = AuthHandler Wai.Request () type HmacAuthContextHandlers = '[HmacAuthHandler] type HmacAuthContext = Context HmacAuthContextHandlers -hmacAuthServerContext :: +hmacAuthServerContext :: (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthContext +hmacAuthServerContext = hmacAuthServerContext' defaultAuthHeaderName + +hmacAuthServerContext' :: -- | Auth header name HeaderName -> -- | Signing function @@ -48,10 +52,13 @@ hmacAuthServerContext :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthContext -hmacAuthServerContext authHeaderName signer sk = hmacAuthHandler authHeaderName signer sk :. EmptyContext +hmacAuthServerContext' authHeaderName signer sk = hmacAuthHandler' authHeaderName signer sk :. EmptyContext + +hmacAuthHandler :: (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthHandler +hmacAuthHandler = hmacAuthHandler' defaultAuthHeaderName -- | Create 'HmacAuthHandler' from signing function and secret key. -hmacAuthHandler :: +hmacAuthHandler' :: -- | Auth header name HeaderName -> -- | Signing function @@ -59,14 +66,18 @@ hmacAuthHandler :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandler authHeaderName = hmacAuthHandlerMap authHeaderName pure +hmacAuthHandler' authHeaderName = hmacAuthHandlerMap' authHeaderName pure {- | Like 'hmacAuthHandler' but allows to specify additional mapping function for 'Wai.Request'. This can be useful if you want to print incoming request (for logging purposes) or filter some headers (to match signature). Given function is applied before signature verification. -} -hmacAuthHandlerMap :: + +hmacAuthHandlerMap :: (Wai.Request -> Handler Wai.Request) -> (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthHandler +hmacAuthHandlerMap = hmacAuthHandlerMap' defaultAuthHeaderName + +hmacAuthHandlerMap' :: -- | Auth header name HeaderName -> -- | Request mapper @@ -76,13 +87,13 @@ hmacAuthHandlerMap :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandlerMap authHeaderName mapper signer sk = mkAuthHandler handler +hmacAuthHandlerMap' authHeaderName mapper signer sk = mkAuthHandler handler where handler :: Wai.Request -> Handler () handler req = do newReq <- mapper req - let payload = waiRequestToPayload authHeaderName newReq - let verification = verifySignatureHmac authHeaderName signer sk payload + let payload = waiRequestToPayload' authHeaderName newReq + let verification = verifySignatureHmac' authHeaderName signer sk payload case verification of Nothing -> pure () Just bs -> throwError $ err401{errBody = bs} @@ -100,12 +111,15 @@ hmacAuthHandlerMap authHeaderName mapper signer sk = mkAuthHandler handler -- then pure [] -- else (chunk:) <$> getChunks -waiRequestToPayload :: HeaderName -> Wai.Request -> RequestPayload +waiRequestToPayload :: Wai.Request -> RequestPayload +waiRequestToPayload = waiRequestToPayload' defaultAuthHeaderName + +waiRequestToPayload' :: HeaderName -> Wai.Request -> RequestPayload -- waiRequestToPayload req = getWaiRequestBody req >>= \body -> pure RequestPayload -waiRequestToPayload authHeaderName req = +waiRequestToPayload' authHeaderName req = RequestPayload { rpMethod = requestMethod req , rpContent = "" - , rpHeaders = keepWhitelistedHeaders authHeaderName $ requestHeaders req + , rpHeaders = keepWhitelistedHeaders' authHeaderName $ requestHeaders req , rpRawUrl = fromMaybe mempty (requestHeaderHost req) <> rawPathInfo req <> rawQueryString req } diff --git a/test/Servant/Auth/HmacSpec.hs b/test/Servant/Auth/HmacSpec.hs index 910f806..0ea3201 100644 --- a/test/Servant/Auth/HmacSpec.hs +++ b/test/Servant/Auth/HmacSpec.hs @@ -23,11 +23,10 @@ import Servant.Auth.Hmac ( HmacAuth, SecretKey (SecretKey), defaultHmacSettings, - hmacAuthServerContext, hmacClient, runHmacClient, - signSHA256, - defaultAuthHeaderName + signSHA256, + defaultAuthHeaderName, hmacAuthServerContext' ) import Servant.Client ( BaseUrl (baseUrlPort), @@ -78,7 +77,7 @@ securedEchoServer :: Server EchoApi securedEchoServer = const echoBack securedEchoApp :: SecretKey -> Application -securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext defaultAuthHeaderName signSHA256 sk) securedEchoServer +securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext' defaultAuthHeaderName signSHA256 sk) securedEchoServer withSecuredEchoApp :: SecretKey -> (Warp.Port -> IO ()) -> IO () withSecuredEchoApp sk = Warp.testWithApplication (pure $ securedEchoApp sk) From 954582cd54dbc2991f5da394a04990b48cd62fbd Mon Sep 17 00:00:00 2001 From: Adlai Arnold Date: Thu, 2 Jun 2022 15:38:28 -0700 Subject: [PATCH 4/5] user can now specify how to generate signature from request --- src/Servant/Auth/Hmac/Crypto.hs | 8 +++++--- src/Servant/Auth/Hmac/Server.hs | 31 +++++++++++++++++-------------- test/Servant/Auth/HmacSpec.hs | 5 ++--- 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs index ba0de7d..788f3e7 100644 --- a/src/Servant/Auth/Hmac/Crypto.hs +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -180,9 +180,11 @@ if it is true, and 'Just' error message otherwise. -} verifySignatureHmac :: (SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Maybe Lazy.ByteString -verifySignatureHmac = verifySignatureHmac' defaultAuthHeaderName +verifySignatureHmac = verifySignatureHmac' requestSignature defaultAuthHeaderName verifySignatureHmac' :: + -- | Function to extract signature from request: takes signing function, secret key, and request + ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> -- | Auth header name HeaderName -> -- | Signing function @@ -191,10 +193,10 @@ verifySignatureHmac' :: SecretKey -> RequestPayload -> Maybe LBS.ByteString -verifySignatureHmac' authHeaderName signer sk signedPayload = case unsignedPayload of +verifySignatureHmac' mkRequestSignature authHeaderName signer sk signedPayload = case unsignedPayload of Left err -> Just err Right (pay, sig) -> - if sig == requestSignature signer sk pay + if sig == mkRequestSignature signer sk pay then Nothing else Just "Signatures don't match" where diff --git a/src/Servant/Auth/Hmac/Server.hs b/src/Servant/Auth/Hmac/Server.hs index 6c9ebf1..7112214 100644 --- a/src/Servant/Auth/Hmac/Server.hs +++ b/src/Servant/Auth/Hmac/Server.hs @@ -27,7 +27,7 @@ import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHand import Servant.Auth.Hmac.Crypto ( RequestPayload (..), SecretKey, - Signature, verifySignatureHmac', keepWhitelistedHeaders', defaultAuthHeaderName + Signature, verifySignatureHmac', keepWhitelistedHeaders', defaultAuthHeaderName, requestSignature ) import qualified Network.Wai as Wai (Request) @@ -42,9 +42,11 @@ type HmacAuthContextHandlers = '[HmacAuthHandler] type HmacAuthContext = Context HmacAuthContextHandlers hmacAuthServerContext :: (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthContext -hmacAuthServerContext = hmacAuthServerContext' defaultAuthHeaderName +hmacAuthServerContext = hmacAuthServerContext' requestSignature defaultAuthHeaderName hmacAuthServerContext' :: + -- | Function to extract signature from request: takes signing function, secret key, and request + ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> -- | Auth header name HeaderName -> -- | Signing function @@ -52,13 +54,15 @@ hmacAuthServerContext' :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthContext -hmacAuthServerContext' authHeaderName signer sk = hmacAuthHandler' authHeaderName signer sk :. EmptyContext +hmacAuthServerContext' mkRequestSignature authHeaderName signer sk = hmacAuthHandler' mkRequestSignature authHeaderName signer sk :. EmptyContext hmacAuthHandler :: (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthHandler -hmacAuthHandler = hmacAuthHandler' defaultAuthHeaderName +hmacAuthHandler = hmacAuthHandler' requestSignature defaultAuthHeaderName -- | Create 'HmacAuthHandler' from signing function and secret key. hmacAuthHandler' :: + -- | Function to extract signature from request: takes signing function, secret key, and request + ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> -- | Auth header name HeaderName -> -- | Signing function @@ -66,7 +70,7 @@ hmacAuthHandler' :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandler' authHeaderName = hmacAuthHandlerMap' authHeaderName pure +hmacAuthHandler' mkRequestSignature authHeaderName = hmacAuthHandlerMap' mkRequestSignature authHeaderName pure {- | Like 'hmacAuthHandler' but allows to specify additional mapping function for 'Wai.Request'. This can be useful if you want to print incoming request (for @@ -75,9 +79,11 @@ applied before signature verification. -} hmacAuthHandlerMap :: (Wai.Request -> Handler Wai.Request) -> (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthHandler -hmacAuthHandlerMap = hmacAuthHandlerMap' defaultAuthHeaderName +hmacAuthHandlerMap = hmacAuthHandlerMap' requestSignature defaultAuthHeaderName hmacAuthHandlerMap' :: + -- | Function to extract signature from request: takes signing function, secret key, and request + ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> -- | Auth header name HeaderName -> -- | Request mapper @@ -87,13 +93,13 @@ hmacAuthHandlerMap' :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandlerMap' authHeaderName mapper signer sk = mkAuthHandler handler +hmacAuthHandlerMap' mkRequestSignature authHeaderName mapper signer sk = mkAuthHandler handler where handler :: Wai.Request -> Handler () handler req = do newReq <- mapper req - let payload = waiRequestToPayload' authHeaderName newReq - let verification = verifySignatureHmac' authHeaderName signer sk payload + let payload = waiRequestToPayload authHeaderName newReq + let verification = verifySignatureHmac' mkRequestSignature authHeaderName signer sk payload case verification of Nothing -> pure () Just bs -> throwError $ err401{errBody = bs} @@ -111,12 +117,9 @@ hmacAuthHandlerMap' authHeaderName mapper signer sk = mkAuthHandler handler -- then pure [] -- else (chunk:) <$> getChunks -waiRequestToPayload :: Wai.Request -> RequestPayload -waiRequestToPayload = waiRequestToPayload' defaultAuthHeaderName - -waiRequestToPayload' :: HeaderName -> Wai.Request -> RequestPayload +waiRequestToPayload :: HeaderName -> Wai.Request -> RequestPayload -- waiRequestToPayload req = getWaiRequestBody req >>= \body -> pure RequestPayload -waiRequestToPayload' authHeaderName req = +waiRequestToPayload authHeaderName req = RequestPayload { rpMethod = requestMethod req , rpContent = "" diff --git a/test/Servant/Auth/HmacSpec.hs b/test/Servant/Auth/HmacSpec.hs index 0ea3201..5f9e657 100644 --- a/test/Servant/Auth/HmacSpec.hs +++ b/test/Servant/Auth/HmacSpec.hs @@ -25,8 +25,7 @@ import Servant.Auth.Hmac ( defaultHmacSettings, hmacClient, runHmacClient, - signSHA256, - defaultAuthHeaderName, hmacAuthServerContext' + signSHA256, hmacAuthServerContext ) import Servant.Client ( BaseUrl (baseUrlPort), @@ -77,7 +76,7 @@ securedEchoServer :: Server EchoApi securedEchoServer = const echoBack securedEchoApp :: SecretKey -> Application -securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext' defaultAuthHeaderName signSHA256 sk) securedEchoServer +securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext signSHA256 sk) securedEchoServer withSecuredEchoApp :: SecretKey -> (Warp.Port -> IO ()) -> IO () withSecuredEchoApp sk = Warp.testWithApplication (pure $ securedEchoApp sk) From 988465c9959782c075e2ff37ef881f66054c8faa Mon Sep 17 00:00:00 2001 From: Adlai Arnold Date: Thu, 2 Jun 2022 15:56:39 -0700 Subject: [PATCH 5/5] user can now specify how to extract signature from header --- src/Servant/Auth/Hmac/Crypto.hs | 37 +++++++++++++++++---------------- src/Servant/Auth/Hmac/Server.hs | 29 ++++++++++++++++---------- 2 files changed, 37 insertions(+), 29 deletions(-) diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs index 788f3e7..626df4b 100644 --- a/src/Servant/Auth/Hmac/Crypto.hs +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -19,7 +19,8 @@ module Servant.Auth.Hmac.Crypto ( keepWhitelistedHeaders', -- * Internal - defaultAuthHeaderName + defaultAuthHeaderName, + unsignedPayload ) where import Crypto.Hash (hash) @@ -35,7 +36,6 @@ import qualified Data.ByteArray as BA (convert) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy as Lazy -- | The wraper for the secret key. newtype SecretKey = SecretKey @@ -179,12 +179,14 @@ It checks whether @@ is true request signature. Function returns 'Not if it is true, and 'Just' error message otherwise. -} -verifySignatureHmac :: (SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Maybe Lazy.ByteString -verifySignatureHmac = verifySignatureHmac' requestSignature defaultAuthHeaderName +verifySignatureHmac :: (SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Maybe LBS.ByteString +verifySignatureHmac = verifySignatureHmac' requestSignature unsignedPayload defaultAuthHeaderName verifySignatureHmac' :: - -- | Function to extract signature from request: takes signing function, secret key, and request + -- | Function to generate signature from request: takes signing function, secret key, and request ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> + -- | Function to extract signature from request + (RequestPayload -> HeaderName -> Either LBS.ByteString (RequestPayload, Signature)) -> -- | Auth header name HeaderName -> -- | Signing function @@ -193,24 +195,12 @@ verifySignatureHmac' :: SecretKey -> RequestPayload -> Maybe LBS.ByteString -verifySignatureHmac' mkRequestSignature authHeaderName signer sk signedPayload = case unsignedPayload of +verifySignatureHmac' mkRequestSignature extractSignature authHeaderName signer sk signedPayload = case extractSignature signedPayload authHeaderName of Left err -> Just err Right (pay, sig) -> if sig == mkRequestSignature signer sk pay then Nothing else Just "Signatures don't match" - where - -- Extracts HMAC signature from request and returns request with @authHeaderName@ header - unsignedPayload :: Either LBS.ByteString (RequestPayload, Signature) - unsignedPayload = case extractOn (isAuthHeader authHeaderName) $ rpHeaders signedPayload of - (Nothing, _) -> Left $ "No '" <> Lazy.fromStrict (original authHeaderName) <> "' header" - (Just (_, val), headers) -> case BS.stripPrefix "HMAC " val of - Just sig -> - Right - ( signedPayload{rpHeaders = headers} - , Signature sig - ) - Nothing -> Left "Can not strip 'HMAC' prefix in header" ---------------------------------------------------------------------------- -- Internals @@ -238,3 +228,14 @@ extractOn p l = in case uncons after of Nothing -> (Nothing, l) Just (x, xs) -> (Just x, before ++ xs) + +unsignedPayload :: RequestPayload -> HeaderName -> Either LBS.ByteString (RequestPayload, Signature) +unsignedPayload signedPayload authHeaderName = case extractOn (isAuthHeader authHeaderName) $ rpHeaders signedPayload of + (Nothing, _) -> Left $ "No '" <> LBS.fromStrict (original authHeaderName) <> "' header" + (Just (_, val), headers) -> case BS.stripPrefix "HMAC " val of + Just sig -> + Right + ( signedPayload{rpHeaders = headers} + , Signature sig + ) + Nothing -> Left "Can not strip 'HMAC' prefix in header" \ No newline at end of file diff --git a/src/Servant/Auth/Hmac/Server.hs b/src/Servant/Auth/Hmac/Server.hs index 7112214..bd18885 100644 --- a/src/Servant/Auth/Hmac/Server.hs +++ b/src/Servant/Auth/Hmac/Server.hs @@ -27,11 +27,12 @@ import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHand import Servant.Auth.Hmac.Crypto ( RequestPayload (..), SecretKey, - Signature, verifySignatureHmac', keepWhitelistedHeaders', defaultAuthHeaderName, requestSignature + Signature, verifySignatureHmac', keepWhitelistedHeaders', defaultAuthHeaderName, requestSignature, unsignedPayload ) import qualified Network.Wai as Wai (Request) import Network.HTTP.Types +import qualified Data.ByteString.Lazy as LBS type HmacAuth = AuthProtect "hmac-auth" @@ -42,11 +43,13 @@ type HmacAuthContextHandlers = '[HmacAuthHandler] type HmacAuthContext = Context HmacAuthContextHandlers hmacAuthServerContext :: (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthContext -hmacAuthServerContext = hmacAuthServerContext' requestSignature defaultAuthHeaderName +hmacAuthServerContext = hmacAuthServerContext' requestSignature unsignedPayload defaultAuthHeaderName hmacAuthServerContext' :: - -- | Function to extract signature from request: takes signing function, secret key, and request + -- | Function to generate signature from request: takes signing function, secret key, and request ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> + -- | Function to extract signature from request + (RequestPayload -> HeaderName -> Either LBS.ByteString (RequestPayload, Signature)) -> -- | Auth header name HeaderName -> -- | Signing function @@ -54,15 +57,17 @@ hmacAuthServerContext' :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthContext -hmacAuthServerContext' mkRequestSignature authHeaderName signer sk = hmacAuthHandler' mkRequestSignature authHeaderName signer sk :. EmptyContext +hmacAuthServerContext' mkRequestSignature extractSignature authHeaderName signer sk = hmacAuthHandler' mkRequestSignature extractSignature authHeaderName signer sk :. EmptyContext hmacAuthHandler :: (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthHandler -hmacAuthHandler = hmacAuthHandler' requestSignature defaultAuthHeaderName +hmacAuthHandler = hmacAuthHandler' requestSignature unsignedPayload defaultAuthHeaderName -- | Create 'HmacAuthHandler' from signing function and secret key. hmacAuthHandler' :: - -- | Function to extract signature from request: takes signing function, secret key, and request + -- | Function to generate signature from request: takes signing function, secret key, and request ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> + -- | Function to extract signature from request + (RequestPayload -> HeaderName -> Either LBS.ByteString (RequestPayload, Signature)) -> -- | Auth header name HeaderName -> -- | Signing function @@ -70,7 +75,7 @@ hmacAuthHandler' :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandler' mkRequestSignature authHeaderName = hmacAuthHandlerMap' mkRequestSignature authHeaderName pure +hmacAuthHandler' mkRequestSignature extractSignature authHeaderName = hmacAuthHandlerMap' mkRequestSignature extractSignature authHeaderName pure {- | Like 'hmacAuthHandler' but allows to specify additional mapping function for 'Wai.Request'. This can be useful if you want to print incoming request (for @@ -79,11 +84,13 @@ applied before signature verification. -} hmacAuthHandlerMap :: (Wai.Request -> Handler Wai.Request) -> (SecretKey -> ByteString -> Signature) -> SecretKey -> HmacAuthHandler -hmacAuthHandlerMap = hmacAuthHandlerMap' requestSignature defaultAuthHeaderName +hmacAuthHandlerMap = hmacAuthHandlerMap' requestSignature unsignedPayload defaultAuthHeaderName hmacAuthHandlerMap' :: - -- | Function to extract signature from request: takes signing function, secret key, and request + -- | Function to generate signature from request: takes signing function, secret key, and request ((SecretKey -> ByteString -> Signature) -> SecretKey -> RequestPayload -> Signature) -> + -- | Function to extract signature from request + (RequestPayload -> HeaderName -> Either LBS.ByteString (RequestPayload, Signature)) -> -- | Auth header name HeaderName -> -- | Request mapper @@ -93,13 +100,13 @@ hmacAuthHandlerMap' :: -- | Secret key that was used for signing 'Request' SecretKey -> HmacAuthHandler -hmacAuthHandlerMap' mkRequestSignature authHeaderName mapper signer sk = mkAuthHandler handler +hmacAuthHandlerMap' mkRequestSignature extractSignature authHeaderName mapper signer sk = mkAuthHandler handler where handler :: Wai.Request -> Handler () handler req = do newReq <- mapper req let payload = waiRequestToPayload authHeaderName newReq - let verification = verifySignatureHmac' mkRequestSignature authHeaderName signer sk payload + let verification = verifySignatureHmac' mkRequestSignature extractSignature authHeaderName signer sk payload case verification of Nothing -> pure () Just bs -> throwError $ err401{errBody = bs}