user can now specify signature auth header name

src/Servant/Auth/Hmac/Client.hs

@@ -41,14 +41,14 @@ import Servant.Auth.Hmac.Crypto (
     RequestPayload (..),
     SecretKey,
     Signature (..),
-    authHeaderName,
     keepWhitelistedHeaders,
     requestSignature,
     signSHA256,
  )
 
 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,20 +59,24 @@ 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:
 
 1. Signing function is 'signSHA256'.
 2. Secret key is provided.
 3. 'hmacRequestHook' is 'Nothing'.
+4. 'hmacAuthHeaderName' is 'Authentication'.
 -}
 defaultHmacSettings :: SecretKey -> HmacSettings
 defaultHmacSettings sk =
     HmacSettings
         { 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 <signature>
 @
 -}
 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}

src/Servant/Auth/Hmac/Crypto.hs

@@ -14,24 +14,22 @@ module Servant.Auth.Hmac.Crypto (
     verifySignatureHmac,
     whitelistHeaders,
     keepWhitelistedHeaders,
-
-    -- * Internals
-    authHeaderName,
 ) where
 
 import Crypto.Hash (hash)
 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)
 
 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 @<signature>@ 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

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,42 +41,48 @@ 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
 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
     (SecretKey -> ByteString -> Signature) ->
     -- | 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
         }

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)