diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,11 +3,27 @@ `servant-hmac-auth` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. +## 0.1.5 - Jan 27, 2023 +* Bump dependency upper bounds, allow building with `GHC 9.0`, `9.2` and `9.4` +## 0.1.4 - March 8, 2022 + +* [#55](https://github.com/Holmusk/servant-hmac-auth/pull/55): + **Breaking change:** non-standard http(s) port are now included in the HMAC signature. + + _Migration guide_: if you are communicating over the standard http(s) port (`80` for http, `443` for https), then you will **not** be impacted. + Otherwise, you need to make sure that both the client and server include the custom http(s) port number in the HMAC signature generation. + This library will do so automatically. + +* [#53](https://github.com/Holmusk/servant-hmac-auth/pull/53): + Servant 0.19 support + +* [#51](https://github.com/Holmusk/servant-hmac-auth/pull/51): + Allow compilation with ghc 8.10.7 + ## 0.1.3 - Nov 29, 2021 * Bump `servant-*` libraries' version to `0.18-*` * Use `GHC 8.8.3` (Stack Resolver `16.2`) - ## Unreleased: 0.1.0 diff --git a/servant-hmac-auth.cabal b/servant-hmac-auth.cabal --- a/servant-hmac-auth.cabal +++ b/servant-hmac-auth.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: servant-hmac-auth -version: 0.1.4 +version: 0.1.5 synopsis: Servant authentication with HMAC description: Servant authentication with HMAC. See README.md for usage example. homepage: https://github.com/holmusk/servant-hmac-auth @@ -14,16 +14,17 @@ build-type: Simple extra-source-files: README.md , CHANGELOG.md -tested-with: GHC == 8.6.5 - GHC == 8.8.4 - GHC == 8.10.7 +tested-with: GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.5 + GHC == 9.4.4 source-repository head type: git location: https://github.com/holmusk/servant-hmac-auth.git common common-options - build-depends: base >= 4.11.1.0 && < 4.15 + build-depends: base >= 4.11.1.0 && < 4.18 ghc-options: -Wall -Wincomplete-uni-patterns @@ -66,14 +67,13 @@ Servant.Auth.Hmac.Server build-depends: base64-bytestring >= 1.0 && <= 2 - , binary ^>= 0.8 - , bytestring ^>= 0.10 + , bytestring ^>= 0.10 || ^>= 0.11 , case-insensitive ^>= 1.2 , containers >= 0.5.7 && < 0.7 - , cryptonite >= 0.25 && < 0.30 + , cryptonite >= 0.25 && < 0.31 , http-types ^>= 0.12 , http-client >= 0.6.4 && < 0.8 - , memory >= 0.15 && < 0.17 + , memory >= 0.15 && < 0.19 , mtl ^>= 2.2.2 , servant ^>= 0.18 || ^>= 0.19 , servant-client ^>= 0.18 || ^>= 0.19 @@ -93,7 +93,12 @@ , filepath , hspec , hspec-golden ^>= 0.2 + , http-client >= 0.6.4 && < 0.8 , http-types ^>= 0.12 + , servant-client ^>= 0.18 || ^>= 0.19 + , servant-server ^>= 0.18 || ^>= 0.19 , text + , warp ^>= 3.3 other-modules: Servant.Auth.Hmac.CryptoSpec + Servant.Auth.HmacSpec build-tool-depends: hspec-discover:hspec-discover == 2.* diff --git a/src/Servant/Auth/Hmac.hs b/src/Servant/Auth/Hmac.hs --- a/src/Servant/Auth/Hmac.hs +++ b/src/Servant/Auth/Hmac.hs @@ -1,10 +1,9 @@ {- | Servant authentication with HMAC. Contains server and client implementation. -} - -module Servant.Auth.Hmac - ( module Hmac - ) where +module Servant.Auth.Hmac ( + module Hmac, +) where import Servant.Auth.Hmac.Client as Hmac import Servant.Auth.Hmac.Crypto as Hmac diff --git a/src/Servant/Auth/Hmac/Client.hs b/src/Servant/Auth/Hmac/Client.hs --- a/src/Servant/Auth/Hmac/Client.hs +++ b/src/Servant/Auth/Hmac/Client.hs @@ -1,19 +1,18 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} -- | Servant client authentication. - -module Servant.Auth.Hmac.Client - ( -- * HMAC client settings - HmacSettings (..) - , defaultHmacSettings +module Servant.Auth.Hmac.Client ( + -- * HMAC client settings + HmacSettings (..), + defaultHmacSettings, - -- * HMAC servant client - , HmacClientM (..) - , runHmacClient - , hmacClient - ) where + -- * HMAC servant client + HmacClientM (..), + runHmacClient, + hmacClient, +) where import Control.Monad ((>=>)) import Control.Monad.IO.Class (MonadIO (..)) @@ -26,29 +25,40 @@ import Data.Proxy (Proxy (..)) import Data.Sequence (fromList, (<|)) import Data.String (fromString) -import Servant.Client (BaseUrl, Client, ClientEnv (baseUrl), ClientError, ClientM, HasClient, - runClientM) +import Servant.Client ( + BaseUrl, + Client, + ClientEnv (baseUrl), + ClientError, + ClientM, + HasClient, + runClientM, + ) import Servant.Client.Core (RunClient (..), clientIn) import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) -import Servant.Auth.Hmac.Crypto (RequestPayload (..), SecretKey, Signature (..), authHeaderName, - keepWhitelistedHeaders, requestSignature, signSHA256) +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 - -- | Environment for 'HmacClientM'. Contains all required settings for hmac client. data HmacSettings = HmacSettings - { -- | Singing function that will sign all outgoing requests. - hmacSigner :: SecretKey -> ByteString -> Signature - - -- | Secret key for signing function. - , hmacSecretKey :: SecretKey - - -- | Function to call for every request after this request is signed. - -- Useful for debugging. + { hmacSigner :: SecretKey -> ByteString -> Signature + -- ^ Singing function that will sign all outgoing requests. + , hmacSecretKey :: SecretKey + -- ^ Secret key for signing function. , hmacRequestHook :: Maybe (Servant.Request -> ClientM ()) + -- ^ Function to call for every request after this request is signed. + -- Useful for debugging. } {- | Default 'HmacSettings' with the following configuration: @@ -58,18 +68,20 @@ 3. 'hmacRequestHook' is 'Nothing'. -} defaultHmacSettings :: SecretKey -> HmacSettings -defaultHmacSettings sk = HmacSettings - { hmacSigner = signSHA256 - , hmacSecretKey = sk - , hmacRequestHook = Nothing - } +defaultHmacSettings sk = + HmacSettings + { hmacSigner = signSHA256 + , hmacSecretKey = sk + , hmacRequestHook = Nothing + } {- | @newtype@ wrapper over 'ClientM' that signs all outgoing requests automatically. -} newtype HmacClientM a = HmacClientM { runHmacClientM :: ReaderT HmacSettings ClientM a - } deriving (Functor, Applicative, Monad, MonadIO, MonadReader HmacSettings) + } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader HmacSettings) hmacifyClient :: ClientM a -> HmacClientM a hmacifyClient = HmacClientM . lift @@ -80,7 +92,7 @@ url <- lift $ asks baseUrl let signedRequest = signRequestHmac hmacSigner hmacSecretKey url req case hmacRequestHook of - Nothing -> pure () + Nothing -> pure () Just hook -> lift $ hook signedRequest pure signedRequest @@ -90,16 +102,16 @@ throwClientError :: ClientError -> HmacClientM a throwClientError = hmacifyClient . throwClientError -runHmacClient - :: HmacSettings - -> ClientEnv - -> HmacClientM a - -> IO (Either ClientError a) +runHmacClient :: + HmacSettings -> + ClientEnv -> + HmacClientM a -> + IO (Either ClientError a) runHmacClient settings env client = runClientM (runReaderT (runHmacClientM client) settings) env -- | Generates a set of client functions for an API. -hmacClient :: forall api . HasClient HmacClientM api => Client HmacClientM api +hmacClient :: forall api. HasClient HmacClientM api => Client HmacClientM api hmacClient = Proxy @api `clientIn` Proxy @HmacClientM ---------------------------------------------------------------------------- @@ -107,22 +119,26 @@ ---------------------------------------------------------------------------- servantRequestToPayload :: BaseUrl -> Servant.Request -> RequestPayload -servantRequestToPayload url sreq = RequestPayload - { rpMethod = Client.method req - , rpContent = "" -- toBsBody $ Client.requestBody req - , rpHeaders = keepWhitelistedHeaders - $ ("Host", hostAndPort) - : ("Accept-Encoding", "gzip") - : Client.requestHeaders req - - , rpRawUrl = hostAndPort <> Client.path req <> Client.queryString req - } +servantRequestToPayload url sreq = + RequestPayload + { rpMethod = Client.method req + , rpContent = "" -- toBsBody $ Client.requestBody req + , rpHeaders = + keepWhitelistedHeaders $ + ("Host", hostAndPort) : + ("Accept-Encoding", "gzip") : + Client.requestHeaders req + , rpRawUrl = hostAndPort <> Client.path req <> Client.queryString req + } where req :: Client.Request - req = defaultMakeClientRequest url sreq - { Servant.requestQueryString = - fromList $ sort $ toList $ Servant.requestQueryString sreq - } + req = + defaultMakeClientRequest + url + sreq + { Servant.requestQueryString = + fromList $ sort $ toList $ Servant.requestQueryString sreq + } hostAndPort :: ByteString hostAndPort = case lookup (mk "Host") (Client.requestHeaders req) of @@ -145,14 +161,19 @@ Authentication: HMAC @ -} -signRequestHmac - :: (SecretKey -> ByteString -> Signature) -- ^ Signing function - -> SecretKey -- ^ Secret key that was used for signing 'Request' - -> BaseUrl -- ^ Base url for servant request - -> Servant.Request -- ^ Original request - -> Servant.Request -- ^ Signed request +signRequestHmac :: + -- | Signing function + (SecretKey -> ByteString -> Signature) -> + -- | Secret key that was used for signing 'Request' + SecretKey -> + -- | Base url for servant request + BaseUrl -> + -- | Original request + Servant.Request -> + -- | Signed request + Servant.Request signRequestHmac signer sk url req = do let payload = servantRequestToPayload url req let signature = requestSignature signer sk payload let authHead = (authHeaderName, "HMAC " <> unSignature signature) - req { Servant.requestHeaders = authHead <| Servant.requestHeaders req } + req{Servant.requestHeaders = authHead <| Servant.requestHeaders req} diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs --- a/src/Servant/Auth/Hmac/Crypto.hs +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -1,24 +1,23 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -- | Crypto primitives for hmac signing. - -module Servant.Auth.Hmac.Crypto - ( -- * Crypto primitives - SecretKey (..) - , Signature (..) - , sign - , signSHA256 +module Servant.Auth.Hmac.Crypto ( + -- * Crypto primitives + SecretKey (..), + Signature (..), + sign, + signSHA256, - -- * Request signing - , RequestPayload (..) - , requestSignature - , verifySignatureHmac - , whitelistHeaders - , keepWhitelistedHeaders + -- * Request signing + RequestPayload (..), + requestSignature, + verifySignatureHmac, + whitelistHeaders, + keepWhitelistedHeaders, - -- * Internals - , authHeaderName - ) where + -- * Internals + authHeaderName, +) where import Crypto.Hash (hash) import Crypto.Hash.Algorithms (MD5, SHA256) @@ -42,20 +41,27 @@ -- | Hashed message used as the signature. Encoded in Base64. newtype Signature = Signature { unSignature :: ByteString - } deriving (Eq) + } + deriving (Eq) {- | Compute the hashed message using the supplied hashing function. And then encode the result in the Base64 encoding. -} -sign :: forall algo . (HashAlgorithm algo) - => SecretKey -- ^ Secret key to use - -> ByteString -- ^ Message to MAC - -> Signature -- ^ Hashed message -sign (SecretKey sk) msg = Signature - $ Base64.encode - $ BA.convert - $ hmacGetDigest - $ hmac @_ @_ @algo sk msg +sign :: + forall algo. + (HashAlgorithm algo) => + -- | Secret key to use + SecretKey -> + -- | Message to MAC + ByteString -> + -- | Hashed message + Signature +sign (SecretKey sk) msg = + Signature $ + Base64.encode $ + BA.convert $ + hmacGetDigest $ + hmac @_ @_ @algo sk msg {-# INLINE sign #-} -- | 'sign' function specialized for 'SHA256' cryptographic algorithm. @@ -69,11 +75,16 @@ -- | Part of the HTTP request that will be signed. data RequestPayload = RequestPayload - { rpMethod :: !Method -- ^ HTTP method - , rpContent :: !ByteString -- ^ Raw content of HTTP body - , rpHeaders :: !RequestHeaders -- ^ All headers of HTTP request - , rpRawUrl :: !ByteString -- ^ Raw request URL with host, path pieces and parameters - } deriving (Show) + { rpMethod :: !Method + -- ^ HTTP method + , rpContent :: !ByteString + -- ^ Raw content of HTTP body + , rpHeaders :: !RequestHeaders + -- ^ All headers of HTTP request + , rpRawUrl :: !ByteString + -- ^ Raw request URL with host, path pieces and parameters + } + deriving (Show) {- | This function signs HTTP request according to the following algorithm: @@ -104,20 +115,25 @@ user-agentMozilla/5.0 @ -} -requestSignature - :: (SecretKey -> ByteString -> Signature) -- ^ Signing function - -> SecretKey -- ^ Secret key to use - -> RequestPayload -- ^ Payload to sign - -> Signature +requestSignature :: + -- | Signing function + (SecretKey -> ByteString -> Signature) -> + -- | Secret key to use + SecretKey -> + -- | Payload to sign + RequestPayload -> + Signature requestSignature signer sk = signer sk . createStringToSign where createStringToSign :: RequestPayload -> ByteString - createStringToSign RequestPayload{..} = BS.intercalate "\n" - [ rpMethod - , hashMD5 rpContent - , normalizeHeaders rpHeaders - , rpRawUrl - ] + createStringToSign RequestPayload{..} = + BS.intercalate + "\n" + [ rpMethod + , hashMD5 rpContent + , normalizeHeaders rpHeaders + , rpRawUrl + ] normalizeHeaders :: [Header] -> ByteString normalizeHeaders = BS.intercalate "\n" . sort . map normalize @@ -152,26 +168,30 @@ It checks whether @@ is true request signature. Function returns 'Nothing' if it is true, and 'Just' error message otherwise. -} -verifySignatureHmac - :: (SecretKey -> ByteString -> Signature) -- ^ Signing function - -> SecretKey -- ^ Secret key that was used for signing 'Request' - -> RequestPayload - -> Maybe LBS.ByteString +verifySignatureHmac :: + -- | 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 - Left err -> Just err - Right (pay, sig) -> if sig == requestSignature signer sk pay - then Nothing - else Just "Signatures don't match" + Left err -> Just err + Right (pay, sig) -> + if sig == requestSignature 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 $ rpHeaders signedPayload of (Nothing, _) -> Left "No 'Authentication' header" (Just (_, val), headers) -> case BS.stripPrefix "HMAC " val of - Just sig -> Right - ( signedPayload { rpHeaders = headers } - , Signature sig - ) + Just sig -> + Right + ( signedPayload{rpHeaders = headers} + , Signature sig + ) Nothing -> Left "Can not strip 'HMAC' prefix in header" ---------------------------------------------------------------------------- @@ -197,6 +217,6 @@ extractOn :: (a -> Bool) -> [a] -> (Maybe a, [a]) extractOn p l = let (before, after) = break p l - in case uncons after of - Nothing -> (Nothing, l) - Just (x, xs) -> (Just x, before ++ xs) + in case uncons after of + Nothing -> (Nothing, l) + Just (x, xs) -> (Just x, before ++ xs) diff --git a/src/Servant/Auth/Hmac/Server.hs b/src/Servant/Auth/Hmac/Server.hs --- a/src/Servant/Auth/Hmac/Server.hs +++ b/src/Servant/Auth/Hmac/Server.hs @@ -1,33 +1,36 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} -- | Servant server authentication. - -module Servant.Auth.Hmac.Server - ( HmacAuth - , HmacAuthContextHandlers - , HmacAuthContext - , HmacAuthHandler - , hmacAuthServerContext - , hmacAuthHandler - , hmacAuthHandlerMap - ) where +module Servant.Auth.Hmac.Server ( + HmacAuth, + HmacAuthContextHandlers, + HmacAuthContext, + HmacAuthHandler, + hmacAuthServerContext, + hmacAuthHandler, + hmacAuthHandlerMap, +) where import Control.Monad.Except (throwError) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Network.Wai (rawPathInfo, rawQueryString, requestHeaderHost, requestHeaders, requestMethod) -import Servant (Context ((:.), EmptyContext)) +import Servant (Context (EmptyContext, (:.))) import Servant.API (AuthProtect) import Servant.Server (Handler, err401, errBody) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) -import Servant.Auth.Hmac.Crypto (RequestPayload (..), SecretKey, Signature, keepWhitelistedHeaders, - verifySignatureHmac) +import Servant.Auth.Hmac.Crypto ( + RequestPayload (..), + SecretKey, + Signature, + keepWhitelistedHeaders, + verifySignatureHmac, + ) import qualified Network.Wai as Wai (Request) - type HmacAuth = AuthProtect "hmac-auth" type instance AuthServerData HmacAuth = () @@ -36,17 +39,21 @@ type HmacAuthContextHandlers = '[HmacAuthHandler] type HmacAuthContext = Context HmacAuthContextHandlers -hmacAuthServerContext - :: (SecretKey -> ByteString -> Signature) -- ^ Signing function - -> SecretKey -- ^ Secret key that was used for signing 'Request' - -> HmacAuthContext +hmacAuthServerContext :: + -- | Signing function + (SecretKey -> ByteString -> Signature) -> + -- | Secret key that was used for signing 'Request' + SecretKey -> + HmacAuthContext hmacAuthServerContext signer sk = hmacAuthHandler signer sk :. EmptyContext -- | Create 'HmacAuthHandler' from signing function and secret key. -hmacAuthHandler - :: (SecretKey -> ByteString -> Signature) -- ^ Signing function - -> SecretKey -- ^ Secret key that was used for signing 'Request' - -> HmacAuthHandler +hmacAuthHandler :: + -- | Signing function + (SecretKey -> ByteString -> Signature) -> + -- | Secret key that was used for signing 'Request' + SecretKey -> + HmacAuthHandler hmacAuthHandler = hmacAuthHandlerMap pure {- | Like 'hmacAuthHandler' but allows to specify additional mapping function @@ -54,11 +61,14 @@ logging purposes) or filter some headers (to match signature). Given function is applied before signature verification. -} -hmacAuthHandlerMap - :: (Wai.Request -> Handler Wai.Request) -- ^ Request mapper - -> (SecretKey -> ByteString -> Signature) -- ^ Signing function - -> SecretKey -- ^ Secret key that was used for signing 'Request' - -> HmacAuthHandler +hmacAuthHandlerMap :: + -- | 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 where handler :: Wai.Request -> Handler () @@ -68,7 +78,7 @@ let verification = verifySignatureHmac signer sk payload case verification of Nothing -> pure () - Just bs -> throwError $ err401 { errBody = bs } + Just bs -> throwError $ err401{errBody = bs} ---------------------------------------------------------------------------- -- Internals @@ -85,9 +95,10 @@ waiRequestToPayload :: Wai.Request -> RequestPayload -- waiRequestToPayload req = getWaiRequestBody req >>= \body -> pure RequestPayload -waiRequestToPayload req = RequestPayload - { rpMethod = requestMethod req - , rpContent = "" - , rpHeaders = keepWhitelistedHeaders $ requestHeaders req - , rpRawUrl = fromMaybe mempty (requestHeaderHost req) <> rawPathInfo req <> rawQueryString req - } +waiRequestToPayload req = + RequestPayload + { rpMethod = requestMethod req + , rpContent = "" + , rpHeaders = keepWhitelistedHeaders $ 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 new file mode 100644 --- /dev/null +++ b/test/Servant/Auth/HmacSpec.hs @@ -0,0 +1,133 @@ +module Servant.Auth.HmacSpec (spec) where + +import Data.Text (Text) +import qualified Data.Text as Text +import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Types (Status, unauthorized401) +import qualified Network.Wai.Handler.Warp as Warp +import Servant ( + Application, + Handler, + MimeRender, + MimeUnrender, + PlainText, + Post, + Proxy (Proxy), + ReqBody, + Server, + serve, + serveWithContext, + type (:>), + ) +import Servant.Auth.Hmac ( + HmacAuth, + SecretKey (SecretKey), + defaultHmacSettings, + hmacAuthServerContext, + hmacClient, + runHmacClient, + signSHA256, + ) +import Servant.Client ( + BaseUrl (baseUrlPort), + ClientError (..), + ResponseF (responseStatusCode), + client, + mkClientEnv, + parseBaseUrl, + runClientM, + ) +import Test.Hspec ( + Expectation, + Spec, + around, + context, + describe, + expectationFailure, + it, + runIO, + shouldBe, + ) + +newtype EchoMessage = EchoMessage + {emContent :: Text} + deriving stock (Eq, Show) + deriving (MimeRender PlainText, MimeUnrender PlainText) via Text + +type EchoApi = + HmacAuth :> UnprotectedEchoApi + +type UnprotectedEchoApi = + -- Echo back a reversed message. + "echo" :> ReqBody '[PlainText] EchoMessage :> Post '[PlainText] EchoMessage + +echoBack :: EchoMessage -> Handler EchoMessage +echoBack (EchoMessage msg) = pure $ EchoMessage (Text.reverse msg) + +unsecuredEchoServer :: Server UnprotectedEchoApi +unsecuredEchoServer = echoBack + +unsecuredEchoApp :: Application +unsecuredEchoApp = serve (Proxy @UnprotectedEchoApi) unsecuredEchoServer + +withUnsecuredEchoApp :: (Warp.Port -> IO ()) -> IO () +withUnsecuredEchoApp = Warp.testWithApplication (pure unsecuredEchoApp) + +securedEchoServer :: Server EchoApi +securedEchoServer = const echoBack + +securedEchoApp :: SecretKey -> Application +securedEchoApp sk = serveWithContext (Proxy @EchoApi) (hmacAuthServerContext signSHA256 sk) securedEchoServer + +withSecuredEchoApp :: SecretKey -> (Warp.Port -> IO ()) -> IO () +withSecuredEchoApp sk = Warp.testWithApplication (pure $ securedEchoApp sk) + +shouldBeASuccessWith :: (Show a, Eq a) => Either ClientError a -> a -> Expectation +errA `shouldBeASuccessWith` a = errA `shouldBe` Right a + +shouldBeAFailureWithStatus :: (Show a) => Either ClientError a -> Status -> Expectation +Left (FailureResponse _ resp) `shouldBeAFailureWithStatus` status = responseStatusCode resp `shouldBe` status +Left (DecodeFailure _ resp) `shouldBeAFailureWithStatus` status = responseStatusCode resp `shouldBe` status +Left (UnsupportedContentType _ resp) `shouldBeAFailureWithStatus` status = responseStatusCode resp `shouldBe` status +Left (InvalidContentTypeHeader resp) `shouldBeAFailureWithStatus` status = responseStatusCode resp `shouldBe` status +Left (ConnectionError e) `shouldBeAFailureWithStatus` status = expectationFailure $ "Expected '" <> show status <> "', got this instead: " <> show e +Right a `shouldBeAFailureWithStatus` status = expectationFailure $ "Expected '" <> show status <> "', got this instead: " <> show a + +spec :: Spec +spec = + describe "Hmac" $ do + let sk = SecretKey "not-so-secret-secret-key!" + let anotherSk = SecretKey "some-other-key!!" + + context "with a secured server" $ do + around (withSecuredEchoApp sk) $ do + let securedEchoBack = hmacClient @UnprotectedEchoApi + let unsecuredEchoBack = client (Proxy @UnprotectedEchoApi) + + baseUrl <- runIO $ parseBaseUrl "http://localhost" + manager <- runIO $ newManager defaultManagerSettings + let clientEnv port = mkClientEnv manager (baseUrl{baseUrlPort = port}) + + it "should have the server authenticate the client's secured request with the same secret" $ \port -> do + result <- runHmacClient (defaultHmacSettings sk) (clientEnv port) (securedEchoBack $ EchoMessage "abcdef123789") + result `shouldBeASuccessWith` EchoMessage "987321fedcba" + + it "should have the server reject the client's secured request with a different secret and respond with a 401 status code" $ \port -> do + result <- runHmacClient (defaultHmacSettings anotherSk) (clientEnv port) (securedEchoBack $ EchoMessage "very sensitive message") + result `shouldBeAFailureWithStatus` unauthorized401 + + it "should have the server reject the client's insecured request and respond with a 401 status code" $ \port -> do + result <- runClientM (unsecuredEchoBack $ EchoMessage "very sensitive message") (clientEnv port) + result `shouldBeAFailureWithStatus` unauthorized401 + + context "with an unsecured server" $ do + around withUnsecuredEchoApp $ do + let securedEchoBack = hmacClient @UnprotectedEchoApi + + baseUrl <- runIO $ parseBaseUrl "http://localhost" + manager <- runIO $ newManager defaultManagerSettings + let clientEnv port = mkClientEnv manager (baseUrl{baseUrlPort = port}) + + it "should have the server respond to the client and ignore the client request's HMAC signature" $ \port -> do + result <- runHmacClient (defaultHmacSettings sk) (clientEnv port) (securedEchoBack $ EchoMessage "abcdef123789") + result `shouldBeASuccessWith` EchoMessage "987321fedcba" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs