diff --git a/.gitignore b/.gitignore index a57105d..9f9a65a 100644 --- a/.gitignore +++ b/.gitignore @@ -23,6 +23,8 @@ cabal.project.local .HTF/ # Stack .stack-work/ +stack.yaml +stack.yaml.lock stack-*.yaml.lock ### IDE/support diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..e7f67ff --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,8 @@ +indentation: 4 +comma-style: leading # for lists, tuples etc. - can also be 'trailing' +record-brace-space: false # rec {x = 1} vs. rec{x = 1} +indent-wheres: false # 'false' means save space by only half-indenting the 'where' keyword +diff-friendly-import-export: true # 'false' uses Ormolu-style lists +respectful: true # don't be too opinionated about newlines etc. +haddock-style: multi-line # '--' vs. '{-' +newlines-between-decls: 1 # number of newlines between top-level declarations diff --git a/servant-hmac-auth.cabal b/servant-hmac-auth.cabal index e419b38..1f174a3 100644 --- a/servant-hmac-auth.cabal +++ b/servant-hmac-auth.cabal @@ -93,7 +93,12 @@ test-suite servant-hmac-auth-test , 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 index 647cceb..cc85092 100644 --- 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 index afdecc5..fe6ab53 100644 --- 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.List (sort) 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 @@ data HmacSettings = HmacSettings 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 @@ hmacClientSign req = HmacClientM $ do 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 @@ instance RunClient HmacClientM where 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 @@ hmacClient = Proxy @api `clientIn` Proxy @HmacClientM ---------------------------------------------------------------------------- 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 @@ servantRequestToPayload url sreq = RequestPayload 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 index dd2ab07..801f5c9 100644 --- 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 - - -- * Request signing - , RequestPayload (..) - , requestSignature - , verifySignatureHmac - , whitelistHeaders - , keepWhitelistedHeaders - - -- * Internals - , authHeaderName - ) where +module Servant.Auth.Hmac.Crypto ( + -- * Crypto primitives + SecretKey (..), + Signature (..), + sign, + signSHA256, + + -- * Request signing + RequestPayload (..), + requestSignature, + verifySignatureHmac, + whitelistHeaders, + keepWhitelistedHeaders, + + -- * Internals + authHeaderName, +) where import Crypto.Hash (hash) import Crypto.Hash.Algorithms (MD5, SHA256) @@ -42,20 +41,27 @@ newtype SecretKey = SecretKey -- | 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 @@ signSHA256 = sign @SHA256 -- | 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 @@ hostfoo.bar.com 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 @@ Authentication: HMAC 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 @@ hashMD5 = BA.convert . hash @_ @MD5 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 index a82c9c4..6bb081a 100644 --- 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 HmacAuthHandler = AuthHandler Wai.Request () 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 @@ 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 - :: (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 @@ hmacAuthHandlerMap mapper signer sk = mkAuthHandler handler 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 @@ hmacAuthHandlerMap mapper signer sk = mkAuthHandler handler 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 index 0000000..5d97df4 --- /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 index 52ef578..a824f8c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} \ No newline at end of file +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}