servant-hmac-auth 0.1.4 → 0.1.5
raw patch · 8 files changed
+371/−166 lines, 8 filesdep +warpdep −binarydep ~basedep ~bytestringdep ~cryptonitePVP ok
version bump matches the API change (PVP)
Dependencies added: warp
Dependencies removed: binary
Dependency ranges changed: base, bytestring, cryptonite, memory
API changes (from Hackage documentation)
Files
- CHANGELOG.md +17/−1
- servant-hmac-auth.cabal +14/−9
- src/Servant/Auth/Hmac.hs +3/−4
- src/Servant/Auth/Hmac/Client.hs +80/−59
- src/Servant/Auth/Hmac/Crypto.hs +78/−58
- src/Servant/Auth/Hmac/Server.hs +46/−35
- test/Servant/Auth/HmacSpec.hs +133/−0
- test/Spec.hs +0/−0
CHANGELOG.md view
@@ -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
servant-hmac-auth.cabal view
@@ -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.*
src/Servant/Auth/Hmac.hs view
@@ -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
src/Servant/Auth/Hmac/Client.hs view
@@ -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 <signature> @ -}-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}
src/Servant/Auth/Hmac/Crypto.hs view
@@ -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 @<signature>@ 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)
src/Servant/Auth/Hmac/Server.hs view
@@ -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+ }
+ test/Servant/Auth/HmacSpec.hs view
@@ -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"
test/Spec.hs view