From 73f79cdeff924eed6b99fc991e59bea1525e4417 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 30 Jun 2020 10:17:36 +0200 Subject: [PATCH 1/6] Use context for error handling --- servant-auth-server/README.lhs | 42 ++- .../src/Servant/Auth/Server.hs | 305 +++++++++--------- .../src/Servant/Auth/Server/Internal.hs | 24 +- .../Servant/Auth/Server/Internal/BasicAuth.hs | 27 +- .../src/Servant/Auth/Server/Internal/Types.hs | 29 ++ .../test/Servant/Auth/ServerSpec.hs | 23 +- shell.nix | 12 + 7 files changed, 265 insertions(+), 197 deletions(-) create mode 100644 shell.nix diff --git a/servant-auth-server/README.lhs b/servant-auth-server/README.lhs index 99f8b03..a0ead2d 100644 --- a/servant-auth-server/README.lhs +++ b/servant-auth-server/README.lhs @@ -44,18 +44,11 @@ data Auth (auths :: [*]) val What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by *either* `Auth1` *or* `Auth2`, and the result of authentication will be of type -`AuthResult Something`, where : +`Something` (which is what your handlers will see). -~~~ haskell -data AuthResult val - = BadPassword - | NoSuchUser - | Authenticated val - | Indefinite -~~~ -Your handlers will get a value of type `AuthResult Something`, and can decide -what to do with it. +If: + ~~~ haskell @@ -79,12 +72,10 @@ type Protected -- | 'Protected' will be protected by 'auths', which we still have to specify. -protected :: Servant.Auth.Server.AuthResult User -> Server Protected --- If we get an "Authenticated v", we can trust the information in v, since --- it was signed by a key we trust. -protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user) --- Otherwise, we return a 401. -protected _ = throwAll err401 +protected :: User -> Server Protected +-- We can trust that the User is accurate, since the information was signed by +-- a key we trust +protected user = return (name user) :<|> return (email user) type Unprotected = "login" @@ -105,7 +96,7 @@ server cs jwts = protected :<|> unprotected cs jwts ~~~ The code is common to all authentications. In order to pick one or more specific -authentication methods, all we need to do is provide the expect configuration +authentication methods, we need to do is provide the expected configuration parameters. ## API tokens @@ -121,11 +112,18 @@ mainWithJWT = do -- We generate the key for signing tokens. This would generally be persisted, -- and kept safely myKey <- generateKey - -- Adding some configurations. All authentications require CookieSettings to - -- be in the context. + -- Adding some configurations. This is specific to JWT let jwtCfg = defaultJWTSettings myKey - cfg = defaultCookieSettings :. jwtCfg :. EmptyContext - --- Here we actually make concrete + -- All authentications also require an AuthErrorHandler to be in the context. + -- That determines how to deal with authentications that failed (because + -- secrets were not present, or because they were incorrect, or because they don't + -- work for the specific type). In this case, we user authErrorHandler401, + -- which returns 401 for no secrets, 403 otherwise + authErrHandler = authErrorHandler401 + -- Here we put everything inside the Servant Context. For technical reasons, + -- all authentications require CookieSettings to be in the context + cfg = defaultCookieSettings :. authErrHandler :. jwtCfg :. EmptyContext + -- Here we actually make concrete the auth type api = Proxy :: Proxy (API '[JWT]) _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) @@ -213,7 +211,7 @@ mainWithCookies = do -- Adding some configurations. 'Cookie' requires, in addition to -- CookieSettings, JWTSettings (for signing), so everything is just as before let jwtCfg = defaultJWTSettings myKey - cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + cfg = defaultCookieSettings :. authErrorHandler401 :. jwtCfg :. EmptyContext --- Here is the actual change api = Proxy :: Proxy (API '[Cookie]) run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) diff --git a/servant-auth-server/src/Servant/Auth/Server.hs b/servant-auth-server/src/Servant/Auth/Server.hs index 157fad8..838dc84 100644 --- a/servant-auth-server/src/Servant/Auth/Server.hs +++ b/servant-auth-server/src/Servant/Auth/Server.hs @@ -1,149 +1,162 @@ module Servant.Auth.Server - ( - -- | This package provides implementations for some common authentication - -- methods. Authentication yields a trustworthy (because generated by the - -- server) value of an some arbitrary type: - -- - -- > type MyApi = Protected - -- > - -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails - -- > - -- > server :: Server Protected - -- > server (Authenticated usr) = ... -- here we know the client really is - -- > -- who she claims to be - -- > server _ = throwAll err401 - -- - -- Additional configuration happens via 'Context'. - -- - -- == Example for Custom Handler - -- To use a custom 'Servant.Server.Handler' it is necessary to use - -- 'Servant.Server.hoistServerWithContext' instead of - -- 'Servant.Server.hoistServer' and specify the 'Context'. - -- - -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the - -- 'Context' to create a specialized function equivalent to - -- 'Servant.Server.hoistServer' for an API that includes cookie - -- authentication. - -- - -- > hoistServerWithAuth - -- > :: HasServer api '[CookieSettings, JWTSettings] - -- > => Proxy api - -- > -> (forall x. m x -> n x) - -- > -> ServerT api m - -- > -> ServerT api n - -- > hoistServerWithAuth api = - -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings]) - - ---------------------------------------------------------------------------- - -- * Auth - -- | Basic types - Auth - , AuthResult(..) - , AuthCheck(..) - - ---------------------------------------------------------------------------- - -- * JWT - -- | JSON Web Tokens (JWT) are a compact and secure way of transferring - -- information between parties. In this library, they are signed by the - -- server (or by some other party posessing the relevant key), and used to - -- indicate the bearer's identity or authorization. - -- - -- Arbitrary information can be encoded - just declare instances for the - -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that - -- usually you'll be trasmitting this information on each request (and - -- response!). - -- - -- Note that, while the tokens are signed, they are not encrypted. Do not put - -- any information you do not wish the client to know in them! - - -- ** Combinator - -- | Re-exported from 'servant-auth' - , JWT - - -- ** Classes - , FromJWT(..) - , ToJWT(..) - - -- ** Related types - , IsMatch(..) - - -- ** Settings - , JWTSettings(..) - , defaultJWTSettings - - -- ** Create check - , jwtAuthCheck - - - ---------------------------------------------------------------------------- - -- * Cookie - -- | Cookies are also a method of identifying and authenticating a user. They - -- are particular common when the client is a browser - - -- ** Combinator - -- | Re-exported from 'servant-auth' - , Cookie - - -- ** Settings - , CookieSettings(..) - , XsrfCookieSettings(..) - , defaultCookieSettings - , defaultXsrfCookieSettings - , makeSessionCookie - , makeSessionCookieBS - , makeXsrfCookie - , makeCsrfCookie - , makeCookie - , makeCookieBS - , acceptLogin - , clearSession - - - -- ** Related types - , IsSecure(..) - , SameSite(..) - , AreAuths - - ---------------------------------------------------------------------------- - -- * BasicAuth - -- ** Combinator - -- | Re-exported from 'servant-auth' - , BasicAuth - - -- ** Classes - , FromBasicAuthData(..) - - -- ** Settings - , BasicAuthCfg - - -- ** Related types - , BasicAuthData(..) - , IsPasswordCorrect(..) - - -- ** Authentication request - , wwwAuthenticatedErr - - ---------------------------------------------------------------------------- - -- * Utilies - , ThrowAll(throwAll) - , generateKey - , generateSecret - , fromSecret - , writeKey - , readKey - , makeJWT - - -- ** Re-exports - , Default(def) - , SetCookie - ) where - -import Prelude hiding (readFile, writeFile) -import Data.ByteString (ByteString, writeFile, readFile) -import Data.Default.Class (Default (def)) + ( -- | This package provides implementations for some common authentication + -- methods. Authentication yields a trustworthy (because generated by the + -- server) value of an some arbitrary type: + -- + -- > type MyApi = Protected + -- > + -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails + -- > + -- > server :: Server Protected + -- > server (Authenticated usr) = ... -- here we know the client really is + -- > -- who she claims to be + -- > server _ = throwAll err401 + -- + -- Additional configuration happens via 'Context'. + -- + -- == Example for Custom Handler + -- To use a custom 'Servant.Server.Handler' it is necessary to use + -- 'Servant.Server.hoistServerWithContext' instead of + -- 'Servant.Server.hoistServer' and specify the 'Context'. + -- + -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the + -- 'Context' to create a specialized function equivalent to + -- 'Servant.Server.hoistServer' for an API that includes cookie + -- authentication. + -- + -- > hoistServerWithAuth + -- > :: HasServer api '[CookieSettings, JWTSettings] + -- > => Proxy api + -- > -> (forall x. m x -> n x) + -- > -> ServerT api m + -- > -> ServerT api n + -- > hoistServerWithAuth api = + -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings]) + + ---------------------------------------------------------------------------- + + -- * Auth + + -- | Basic types + Auth, + AuthResult (..), + AuthCheck (..), + AuthErrorHandler (..), + + -- ** AuthErrorHandler functions + redirectWhenNotLoggedIn, + basicAuthErrorHandler, + authErrorHandler401, + ---------------------------------------------------------------------------- + + -- * JWT + + -- | JSON Web Tokens (JWT) are a compact and secure way of transferring + -- information between parties. In this library, they are signed by the + -- server (or by some other party posessing the relevant key), and used to + -- indicate the bearer's identity or authorization. + -- + -- Arbitrary information can be encoded - just declare instances for the + -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that + -- usually you'll be trasmitting this information on each request (and + -- response!). + -- + -- Note that, while the tokens are signed, they are not encrypted. Do not put + -- any information you do not wish the client to know in them! + + -- ** Combinator + + -- | Re-exported from 'servant-auth' + JWT, + + -- ** Classes + FromJWT (..), + ToJWT (..), + + -- ** Related types + IsMatch (..), + + -- ** Settings + JWTSettings (..), + defaultJWTSettings, + + -- ** Create check + jwtAuthCheck, + ---------------------------------------------------------------------------- + + -- * Cookie + + -- | Cookies are also a method of identifying and authenticating a user. They + -- are particular common when the client is a browser + + -- ** Combinator + + -- | Re-exported from 'servant-auth' + Cookie, + + -- ** Settings + CookieSettings (..), + XsrfCookieSettings (..), + defaultCookieSettings, + defaultXsrfCookieSettings, + makeSessionCookie, + makeSessionCookieBS, + makeXsrfCookie, + makeCsrfCookie, + makeCookie, + makeCookieBS, + acceptLogin, + clearSession, + + -- ** Related types + IsSecure (..), + SameSite (..), + AreAuths, + ---------------------------------------------------------------------------- + + -- * BasicAuth + + -- ** Combinator + + -- | Re-exported from 'servant-auth' + BasicAuth, + + -- ** Classes + FromBasicAuthData (..), + + -- ** Settings + BasicAuthCfg, + + -- ** Related types + BasicAuthData (..), + IsPasswordCorrect (..), + + -- ** Authentication request + wwwAuthenticatedErr, + ---------------------------------------------------------------------------- + + -- * Utilies + ThrowAll (throwAll), + generateKey, + generateSecret, + fromSecret, + writeKey, + readKey, + makeJWT, + + -- ** Re-exports + Default (def), + SetCookie, + ) +where + +import Crypto.JOSE as Jose +import Data.ByteString (ByteString, readFile, writeFile) +import Data.Default.Class (Default (def)) +import Servant (BasicAuthData (..)) import Servant.Auth import Servant.Auth.JWT -import Servant.Auth.Server.Internal () +import Servant.Auth.Server.Internal () import Servant.Auth.Server.Internal.BasicAuth import Servant.Auth.Server.Internal.Class import Servant.Auth.Server.Internal.ConfigTypes @@ -151,10 +164,8 @@ import Servant.Auth.Server.Internal.Cookie import Servant.Auth.Server.Internal.JWT import Servant.Auth.Server.Internal.ThrowAll import Servant.Auth.Server.Internal.Types - -import Crypto.JOSE as Jose -import Servant (BasicAuthData (..)) -import Web.Cookie (SetCookie) +import Web.Cookie (SetCookie) +import Prelude hiding (readFile, writeFile) -- | Generate a key suitable for use with 'defaultConfig'. generateKey :: IO Jose.JWK diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal.hs b/servant-auth-server/src/Servant/Auth/Server/Internal.hs index 2e825c0..3ce9490 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal.hs @@ -15,7 +15,6 @@ import Servant.Auth.Server.Internal.AddSetCookie import Servant.Auth.Server.Internal.Class import Servant.Auth.Server.Internal.Cookie import Servant.Auth.Server.Internal.ConfigTypes -import Servant.Auth.Server.Internal.JWT import Servant.Auth.Server.Internal.Types import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest) @@ -27,8 +26,9 @@ instance ( n ~ 'S ('S 'Z) , ToJWT v , HasContextEntry ctxs CookieSettings , HasContextEntry ctxs JWTSettings + , HasContextEntry ctxs AuthErrorHandler ) => HasServer (Auth auths v :> api) ctxs where - type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m + type ServerT (Auth auths v :> api) m = v -> ServerT api m #if MIN_VERSION_servant_server(0,12,0) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s @@ -40,11 +40,12 @@ instance ( n ~ 'S ('S 'Z) (fmap go subserver `addAuthCheck` authCheck) where - authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))) - authCheck = withRequest $ \req -> liftIO $ do - authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req - cookies <- makeCookies authResult - return (authResult, cookies) + authCheck :: DelayedIO (v, SetCookieList ('S ('S 'Z))) + authCheck = withRequest $ \req -> do + authResult <- liftIO $ runAuthCheck (runAuths (Proxy :: Proxy auths) context) req + cookies <- liftIO $ makeCookies authResult + authVal <- authErrHandler authResult + return (authVal, cookies) jwtSettings :: JWTSettings jwtSettings = getContextEntry context @@ -52,6 +53,9 @@ instance ( n ~ 'S ('S 'Z) cookieSettings :: CookieSettings cookieSettings = getContextEntry context + authErrHandler :: AuthResult v -> DelayedIO v + authErrHandler = getAuthErrorHandler $ getContextEntry context + makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z))) makeCookies authResult = do xsrf <- makeXsrfCookie cookieSettings @@ -64,7 +68,7 @@ instance ( n ~ 'S ('S 'Z) Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil _ -> return $ Nothing `SetCookieCons` SetCookieNil - go :: (AuthResult v -> ServerT api Handler) - -> (AuthResult v, SetCookieList n) + go :: (v -> ServerT api Handler) + -> (v, SetCookieList n) -> ServerT (AddSetCookiesApi n api) Handler - go fn (authResult, cookies) = addSetCookies cookies $ fn authResult + go fn (authVal, cookies) = addSetCookies cookies $ fn authVal diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs index f35eb6f..bd7c42e 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs @@ -7,9 +7,10 @@ module Servant.Auth.Server.Internal.BasicAuth where import qualified Data.ByteString as BS import Servant (BasicAuthData (..), - ServerError (..), err401) + ServerError (..), err401, err403) import Servant.Server.Internal.BasicAuth (decodeBAHdr, mkBAChallengerHdr) +import Servant.Server.Internal.DelayedIO (delayedFailFatal) import Servant.Auth.Server.Internal.Types @@ -19,26 +20,26 @@ import Servant.Auth.Server.Internal.Types wwwAuthenticatedErr :: BS.ByteString -> ServerError wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] } --- | A type holding the configuration for Basic Authentication. +-- | A type holding the configuration for Basic Authentication. -- It is defined as a type family with no arguments, so that -- it can be instantiated to whatever type you need to -- authenticate your users (use @type instance BasicAuthCfg = ...@). --- +-- -- Note that the instantiation is application-wide, -- i.e. there can be only one instance. -- As a consequence, it should not be instantiated in a library. --- +-- -- Basic Authentication expects an element of type 'BasicAuthCfg' -- to be in the 'Context'; that element is then passed automatically -- to the instance of 'FromBasicAuthData' together with the -- authentication data obtained from the client. --- +-- -- If you do not need a configuration for Basic Authentication, -- you can use just @BasicAuthCfg = ()@, and recall to also -- add @()@ to the 'Context'. --- A basic but more interesting example is to take as 'BasicAuthCfg' +-- A basic but more interesting example is to take as 'BasicAuthCfg' -- a list of authorised username/password pairs: --- +-- -- > deriving instance Eq BasicAuthData -- > type instance BasicAuthCfg = [BasicAuthData] -- > instance FromBasicAuthData User where @@ -57,3 +58,15 @@ basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of Nothing -> return Indefinite Just baData -> fromBasicAuthData baData cfg + +-- | An AuthErrorHandler that returns a 403 in case of 'BadPassword' or +-- 'NoSuchUser', and returns a 401 with a `WWW-Authenticate` header for the +-- Basic Authentication in case of 'Indefinite' +-- +-- If you're only using Basic Auth, this is the AuthErrorHandler you want. +basicAuthErrorHandler :: BS.ByteString -> AuthErrorHandler +basicAuthErrorHandler realm = AuthErrorHandler $ \result -> case result of + Authenticated a -> pure a + BadPassword -> delayedFailFatal err403 + NoSuchUser -> delayedFailFatal err403 + Indefinite -> delayedFailFatal (wwwAuthenticatedErr realm) diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs index 8e9e91f..bd955bc 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs @@ -3,12 +3,17 @@ module Servant.Auth.Server.Internal.Types where import Control.Applicative import Control.Monad.Reader +import qualified Data.ByteString as BS import Control.Monad.Time import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import Data.Time (getCurrentTime) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) import GHC.Generics (Generic) import Network.Wai (Request) +import Servant (ServerError(..), err302, err403, err401, throwError) +import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFailFatal) import qualified Control.Monad.Fail as Fail @@ -110,3 +115,27 @@ instance Alternative AuthCheck where instance MonadPlus AuthCheck where mzero = mempty mplus = (<>) + +-- * AuthErrorHandler + +-- | How to handle AuthResult failures. +newtype AuthErrorHandler = AuthErrorHandler + { getAuthErrorHandler :: forall a. AuthResult a -> DelayedIO a } + +-- | An AuthErrorHandler that returns a 403 in case of 'BadPassword' or +-- 'NoSuchUser', and redirects to the provided page in case of 'Indefinite'. +-- Likely the page will be a login page. +redirectWhenNotLoggedIn :: Text -> AuthErrorHandler +redirectWhenNotLoggedIn redirectUrl = AuthErrorHandler $ \result -> case result of + Authenticated a -> pure a + BadPassword -> delayedFailFatal err403 + NoSuchUser -> delayedFailFatal err403 + Indefinite -> delayedFailFatal err302 { errHeaders = [ ("Location", encodeUtf8 redirectUrl) ] } + +authErrorHandler401 :: AuthErrorHandler +authErrorHandler401 = AuthErrorHandler $ \result -> case result of + Authenticated a -> pure a + BadPassword -> delayedFailFatal err403 + NoSuchUser -> delayedFailFatal err403 + Indefinite -> delayedFailFatal err401 + diff --git a/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth-server/test/Servant/Auth/ServerSpec.hs index 75257f3..3df89ce 100644 --- a/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -460,29 +460,30 @@ instance FromBasicAuthData User where -- have to add it type instance BasicAuthCfg = JWK -appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User +appWithCookie :: AreAuths auths '[CookieSettings, AuthErrorHandler, JWTSettings, JWK] User => Proxy (API auths) -> CookieSettings -> Application appWithCookie api ccfg = serveWithContext api ctx $ server ccfg where - ctx = ccfg :. jwtCfg :. theKey :. EmptyContext + ctx = ccfg + :. redirectWhenNotLoggedIn "http://foo.com" + :. jwtCfg + :. theKey + :. EmptyContext -- | Takes a proxy parameter indicating which authentication systems to enable. -app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User +app :: AreAuths auths '[CookieSettings, AuthErrorHandler, JWTSettings, JWK] User => Proxy (API auths) -> Application app api = appWithCookie api cookieCfg server :: CookieSettings -> Server (API auths) server ccfg = - (\authResult -> case authResult of - Authenticated usr -> getInt usr - :<|> postInt usr - :<|> getHeaderInt + (\user -> getInt user + :<|> postInt user + :<|> getHeaderInt #if MIN_VERSION_servant_server(0,15,0) - :<|> return (S.source ["bytestring"]) + :<|> return (S.source ["bytestring"]) #endif - :<|> raw - Indefinite -> throwAll err401 - _ -> throwAll err403 + :<|> raw ) :<|> getLogin :<|> getLogout diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..ef590a0 --- /dev/null +++ b/shell.nix @@ -0,0 +1,12 @@ +{ pkgs ? import {} +}: + +with pkgs; + +mkShell { + name = "servant-auth"; + buildInputs = [ + ghc + stack zlib + ]; +} From 0e750e4927c6c2ddde58883c855695c24500e493 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 30 Jun 2020 11:06:19 +0200 Subject: [PATCH 2/6] Bump lens version --- servant-auth-server/servant-auth-server.cabal | 2 +- servant-auth/servant-auth.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-auth-server/servant-auth-server.cabal b/servant-auth-server/servant-auth-server.cabal index ff38e4d..7aa6239 100644 --- a/servant-auth-server/servant-auth-server.cabal +++ b/servant-auth-server/servant-auth-server.cabal @@ -42,7 +42,7 @@ library , entropy >= 0.4.1.3 && < 0.5 , http-types >= 0.12.2 && < 0.13 , jose >= 0.7.0.0 && < 0.9 - , lens >= 4.16.1 && < 4.19 + , lens >= 4.16.1 && < 4.20 , memory >= 0.14.16 && < 0.16 , monad-time >= 0.3.1.0 && < 0.4 , mtl >= 2.2.2 && < 2.3 diff --git a/servant-auth/servant-auth.cabal b/servant-auth/servant-auth.cabal index 6ffa53a..a1e2053 100644 --- a/servant-auth/servant-auth.cabal +++ b/servant-auth/servant-auth.cabal @@ -36,7 +36,7 @@ library base >= 4.9 && < 4.14 , aeson >= 1.3.1.1 && < 1.5 , jose >= 0.7.0.0 && < 0.9 - , lens >= 4.16.1 && < 4.19 + , lens >= 4.16.1 && < 4.20 , servant >= 0.15 && < 0.18 , text >= 1.2.3.0 && < 1.3 , unordered-containers >= 0.2.9.0 && < 0.3 From a0417dfc9fb725d98ddb9f58701e633fd23194de Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 30 Jun 2020 11:37:19 +0200 Subject: [PATCH 3/6] Remove redirect in tests --- servant-auth-server/test/Servant/Auth/ServerSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth-server/test/Servant/Auth/ServerSpec.hs index 3df89ce..cd0f7ba 100644 --- a/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -465,7 +465,7 @@ appWithCookie :: AreAuths auths '[CookieSettings, AuthErrorHandler, JWTSettings, appWithCookie api ccfg = serveWithContext api ctx $ server ccfg where ctx = ccfg - :. redirectWhenNotLoggedIn "http://foo.com" + :. authErrorHandler401 :. jwtCfg :. theKey :. EmptyContext From a815c01ab4a0489410f6ccb9f7af2c9dde5eb04b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 8 Jul 2020 12:32:40 +0200 Subject: [PATCH 4/6] Switch to URI --- servant-auth-server/servant-auth-server.cabal | 1 + .../src/Servant/Auth/Server/Internal/Types.hs | 14 ++++++++------ 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/servant-auth-server/servant-auth-server.cabal b/servant-auth-server/servant-auth-server.cabal index 7aa6239..d2bf9ed 100644 --- a/servant-auth-server/servant-auth-server.cabal +++ b/servant-auth-server/servant-auth-server.cabal @@ -46,6 +46,7 @@ library , memory >= 0.14.16 && < 0.16 , monad-time >= 0.3.1.0 && < 0.4 , mtl >= 2.2.2 && < 2.3 + , network-uri >= 2.6 && < 2.7 , servant >= 0.13 && < 0.18 , servant-auth == 0.3.* , servant-server >= 0.13 && < 0.18 diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs index bd955bc..bebf0b1 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs @@ -3,16 +3,15 @@ module Servant.Auth.Server.Internal.Types where import Control.Applicative import Control.Monad.Reader -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import Control.Monad.Time import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import Data.Time (getCurrentTime) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import GHC.Generics (Generic) import Network.Wai (Request) -import Servant (ServerError(..), err302, err403, err401, throwError) +import Network.URI (URI, uriToString) +import Servant (ServerError(..), err302, err403, err401) import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFailFatal) import qualified Control.Monad.Fail as Fail @@ -125,12 +124,15 @@ newtype AuthErrorHandler = AuthErrorHandler -- | An AuthErrorHandler that returns a 403 in case of 'BadPassword' or -- 'NoSuchUser', and redirects to the provided page in case of 'Indefinite'. -- Likely the page will be a login page. -redirectWhenNotLoggedIn :: Text -> AuthErrorHandler +-- +-- Remember that you can use servant's safeLink machinery to produce a 'URI'! +redirectWhenNotLoggedIn :: URI -> AuthErrorHandler redirectWhenNotLoggedIn redirectUrl = AuthErrorHandler $ \result -> case result of Authenticated a -> pure a BadPassword -> delayedFailFatal err403 NoSuchUser -> delayedFailFatal err403 - Indefinite -> delayedFailFatal err302 { errHeaders = [ ("Location", encodeUtf8 redirectUrl) ] } + Indefinite -> delayedFailFatal err302 + { errHeaders = [ ("Location", BSC.pack $ uriToString id redirectUrl "") ] } authErrorHandler401 :: AuthErrorHandler authErrorHandler401 = AuthErrorHandler $ \result -> case result of From 58a388602264c74b900d8eb6dcd7767a12b99674 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 5 Aug 2020 13:51:14 +0200 Subject: [PATCH 5/6] Allow IO in JWT keyset --- .../Auth/Server/Internal/ConfigTypes.hs | 160 +++++++++--------- .../Servant/Auth/Server/Internal/Cookie.hs | 3 +- .../src/Servant/Auth/Server/Internal/JWT.hs | 61 ++++--- 3 files changed, 116 insertions(+), 108 deletions(-) diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs index 83e5784..8779f1e 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -1,15 +1,16 @@ module Servant.Auth.Server.Internal.ConfigTypes - ( module Servant.Auth.Server.Internal.ConfigTypes - , Servant.API.IsSecure(..) - ) where + ( module Servant.Auth.Server.Internal.ConfigTypes, + Servant.API.IsSecure (..), + ) +where -import Crypto.JOSE as Jose -import Crypto.JWT as Jose -import qualified Data.ByteString as BS -import Data.Default.Class -import Data.Time -import GHC.Generics (Generic) -import Servant.API (IsSecure(..)) +import Crypto.JOSE as Jose +import Crypto.JWT as Jose +import qualified Data.ByteString as BS +import Data.Default.Class +import Data.Time +import GHC.Generics (Generic) +import Servant.API (IsSecure (..)) data IsMatch = Matches | DoesNotMatch deriving (Eq, Show, Read, Generic, Ord) @@ -26,26 +27,29 @@ data SameSite = AnySite | SameSiteStrict | SameSiteLax deriving (Eq, Show, Read, Generic, Ord) -- | @JWTSettings@ are used to generate cookies, and to verify JWTs. -data JWTSettings = JWTSettings - { - -- | Key used to sign JWT. - signingKey :: Jose.JWK - -- | Algorithm used to sign JWT. - , jwtAlg :: Maybe Jose.Alg - -- | Keys used to validate JWT. - , validationKeys :: Jose.JWKSet - -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the - -- intended recipient of the JWT. - , audienceMatches :: Jose.StringOrURI -> IsMatch - } deriving (Generic) +data JWTSettings + = JWTSettings + { -- | Key used to sign JWT. + signingKey :: Jose.JWK, + -- | Algorithm used to sign JWT. + jwtAlg :: Maybe Jose.Alg, + -- | Keys used to validate JWT. + validationKeys :: IO Jose.JWKSet, + -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the + -- intended recipient of the JWT. + audienceMatches :: Jose.StringOrURI -> IsMatch + } + deriving (Generic) -- | A @JWTSettings@ where the audience always matches. defaultJWTSettings :: Jose.JWK -> JWTSettings -defaultJWTSettings k = JWTSettings - { signingKey = k - , jwtAlg = Nothing - , validationKeys = Jose.JWKSet [k] - , audienceMatches = const Matches } +defaultJWTSettings k = + JWTSettings + { signingKey = k, + jwtAlg = Nothing, + validationKeys = pure $ Jose.JWKSet [k], + audienceMatches = const Matches + } -- | The policies to use when generating cookies. -- @@ -55,73 +59,77 @@ defaultJWTSettings k = JWTSettings -- -- Note that having the setting @Secure@ may cause testing failures if you are -- not testing over HTTPS. -data CookieSettings = CookieSettings - { - -- | 'Secure' means browsers will only send cookies over HTTPS. Default: - -- @Secure@. - cookieIsSecure :: !IsSecure - -- | How long from now until the cookie expires. Default: @Nothing@. - , cookieMaxAge :: !(Maybe DiffTime) - -- | At what time the cookie expires. Default: @Nothing@. - , cookieExpires :: !(Maybe UTCTime) - -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@. - , cookiePath :: !(Maybe BS.ByteString) - -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@. - , cookieDomain :: !(Maybe BS.ByteString) - -- | 'SameSite' settings. Default: @SameSiteLax@. - , cookieSameSite :: !SameSite - -- | What name to use for the cookie used for the session. - , sessionCookieName :: !BS.ByteString - -- | The optional settings to use for XSRF protection. Default: @Just def@. - , cookieXsrfSetting :: !(Maybe XsrfCookieSettings) - } deriving (Eq, Show, Generic) +data CookieSettings + = CookieSettings + { -- | 'Secure' means browsers will only send cookies over HTTPS. Default: + -- @Secure@. + cookieIsSecure :: !IsSecure, + -- | How long from now until the cookie expires. Default: @Nothing@. + cookieMaxAge :: !(Maybe DiffTime), + -- | At what time the cookie expires. Default: @Nothing@. + cookieExpires :: !(Maybe UTCTime), + -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@. + cookiePath :: !(Maybe BS.ByteString), + -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@. + cookieDomain :: !(Maybe BS.ByteString), + -- | 'SameSite' settings. Default: @SameSiteLax@. + cookieSameSite :: !SameSite, + -- | What name to use for the cookie used for the session. + sessionCookieName :: !BS.ByteString, + -- | The optional settings to use for XSRF protection. Default: @Just def@. + cookieXsrfSetting :: !(Maybe XsrfCookieSettings) + } + deriving (Eq, Show, Generic) instance Default CookieSettings where def = defaultCookieSettings defaultCookieSettings :: CookieSettings -defaultCookieSettings = CookieSettings - { cookieIsSecure = Secure - , cookieMaxAge = Nothing - , cookieExpires = Nothing - , cookiePath = Just "/" - , cookieDomain = Nothing - , cookieSameSite = SameSiteLax - , sessionCookieName = "JWT-Cookie" - , cookieXsrfSetting = Just def +defaultCookieSettings = + CookieSettings + { cookieIsSecure = Secure, + cookieMaxAge = Nothing, + cookieExpires = Nothing, + cookiePath = Just "/", + cookieDomain = Nothing, + cookieSameSite = SameSiteLax, + sessionCookieName = "JWT-Cookie", + cookieXsrfSetting = Just def } -- | The policies to use when generating and verifying XSRF cookies -data XsrfCookieSettings = XsrfCookieSettings - { - -- | What name to use for the cookie used for XSRF protection. - xsrfCookieName :: !BS.ByteString - -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@. - , xsrfCookiePath :: !(Maybe BS.ByteString) - -- | What name to use for the header used for XSRF protection. - , xsrfHeaderName :: !BS.ByteString - -- | Exclude GET request method from XSRF protection. - , xsrfExcludeGet :: !Bool - } deriving (Eq, Show, Generic) +data XsrfCookieSettings + = XsrfCookieSettings + { -- | What name to use for the cookie used for XSRF protection. + xsrfCookieName :: !BS.ByteString, + -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@. + xsrfCookiePath :: !(Maybe BS.ByteString), + -- | What name to use for the header used for XSRF protection. + xsrfHeaderName :: !BS.ByteString, + -- | Exclude GET request method from XSRF protection. + xsrfExcludeGet :: !Bool + } + deriving (Eq, Show, Generic) instance Default XsrfCookieSettings where def = defaultXsrfCookieSettings defaultXsrfCookieSettings :: XsrfCookieSettings -defaultXsrfCookieSettings = XsrfCookieSettings - { xsrfCookieName = "XSRF-TOKEN" - , xsrfCookiePath = Just "/" - , xsrfHeaderName = "X-XSRF-TOKEN" - , xsrfExcludeGet = False - } +defaultXsrfCookieSettings = + XsrfCookieSettings + { xsrfCookieName = "XSRF-TOKEN", + xsrfCookiePath = Just "/", + xsrfHeaderName = "X-XSRF-TOKEN", + xsrfExcludeGet = False + } ------------------------------------------------------------------------------ -- Internal {{{ jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings -jwtSettingsToJwtValidationSettings s - = defaultJWTValidationSettings (toBool <$> audienceMatches s) +jwtSettingsToJwtValidationSettings s = + defaultJWTValidationSettings (toBool <$> audienceMatches s) where - toBool Matches = True + toBool Matches = True toBool DoesNotMatch = False -- }}} diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs index da240e6..3fffde7 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs @@ -41,8 +41,9 @@ cookieAuthCheck ccfg jwtCfg = do lookup (sessionCookieName ccfg) cookies verifiedJWT <- liftIO $ runExceptT $ do unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict jwtCookie + valKeys <- liftIO $ validationKeys jwtCfg Jose.verifyClaims (jwtSettingsToJwtValidationSettings jwtCfg) - (validationKeys jwtCfg) + valKeys unverifiedJWT case verifiedJWT of Left (_ :: Jose.JWTError) -> mzero diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs index 1261aa7..afc09fe 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs @@ -1,26 +1,20 @@ module Servant.Auth.Server.Internal.JWT where -import Control.Lens -import Control.Monad.Except -import Control.Monad.Reader -import qualified Crypto.JOSE as Jose -import qualified Crypto.JWT as Jose -import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, - toJSON) -import Data.ByteArray (constEq) -import qualified Data.ByteString as BS +import Control.Lens +import Control.Monad.Except +import Control.Monad.Reader +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose +import Data.ByteArray (constEq) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Data.Time (UTCTime) -import Network.Wai (requestHeaders) - -import Servant.Auth.JWT (FromJWT(..), ToJWT(..)) +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime) +import Network.Wai (requestHeaders) +import Servant.Auth.JWT (FromJWT (..), ToJWT (..)) import Servant.Auth.Server.Internal.ConfigTypes import Servant.Auth.Server.Internal.Types - -- | A JWT @AuthCheck@. You likely won't need to use this directly unless you -- are protecting a @Raw@ endpoint. jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr @@ -34,31 +28,36 @@ jwtAuthCheck config = do return rest verifiedJWT <- liftIO $ runExceptT $ do unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict token - Jose.verifyClaims (jwtSettingsToJwtValidationSettings config) - (validationKeys config) - unverifiedJWT + valKeys <- liftIO $ validationKeys config + Jose.verifyClaims + (jwtSettingsToJwtValidationSettings config) + valKeys + unverifiedJWT case verifiedJWT of Left (_ :: Jose.JWTError) -> mzero Right v -> case decodeJWT v of Left _ -> mzero Right v' -> return v' - - -- | Creates a JWT containing the specified data. The data is stored in the -- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the -- token expires. -makeJWT :: ToJWT a - => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString) +makeJWT :: + ToJWT a => + a -> + JWTSettings -> + Maybe UTCTime -> + IO (Either Jose.Error BSL.ByteString) makeJWT v cfg expiry = runExceptT $ do bestAlg <- Jose.bestJWSAlg $ signingKey cfg let alg = fromMaybe bestAlg $ jwtAlg cfg - ejwt <- Jose.signClaims (signingKey cfg) - (Jose.newJWSHeader ((), alg)) - (addExp $ encodeJWT v) - + ejwt <- + Jose.signClaims + (signingKey cfg) + (Jose.newJWSHeader ((), alg)) + (addExp $ encodeJWT v) return $ Jose.encodeCompact ejwt where - addExp claims = case expiry of - Nothing -> claims - Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e + addExp claims = case expiry of + Nothing -> claims + Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e From 459fff505e5ab80b7103f335b30b56fd8170f5cc Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 7 Aug 2020 11:32:03 +0200 Subject: [PATCH 6/6] wip --- .../src/Servant/Auth/Server.hs | 3 --- .../Auth/Server/Internal/CachedRequest.hs | 22 ++++++++++++++++ .../Auth/Server/Internal/ConfigTypes.hs | 25 ++++--------------- .../Servant/Auth/Server/Internal/Cookie.hs | 2 +- .../src/Servant/Auth/Server/Internal/JWT.hs | 2 +- .../test/Servant/Auth/ServerSpec.hs | 8 ++++-- 6 files changed, 35 insertions(+), 27 deletions(-) create mode 100644 servant-auth-server/src/Servant/Auth/Server/Internal/CachedRequest.hs diff --git a/servant-auth-server/src/Servant/Auth/Server.hs b/servant-auth-server/src/Servant/Auth/Server.hs index 838dc84..cdf6be5 100644 --- a/servant-auth-server/src/Servant/Auth/Server.hs +++ b/servant-auth-server/src/Servant/Auth/Server.hs @@ -73,9 +73,6 @@ module Servant.Auth.Server FromJWT (..), ToJWT (..), - -- ** Related types - IsMatch (..), - -- ** Settings JWTSettings (..), defaultJWTSettings, diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/CachedRequest.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/CachedRequest.hs new file mode 100644 index 0000000..6afdf46 --- /dev/null +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/CachedRequest.hs @@ -0,0 +1,22 @@ +module Servant.Auth.Server.Internal.CachedRequest where + +data RequestCacher = RequestCacher + { expiresAt :: MVar UTCTime + , currentValue :: MVar JWKSet + , requestUrl :: String + } + +-- | +getCacheValue :: RequestCacher a -> IO a +getCacheValue cacher = do + now <- getCurrentTime + expiration <- readMVar $ expiresAt cacher + if expiration < now + then + else + + +newRequestCacher :: String -> IO RequestCacher +newRequestCacher url = do + mgr <- newManager defaultManagerSettings + request <- parseUrlThrow url diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs index 8779f1e..18ebdd4 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -4,17 +4,14 @@ module Servant.Auth.Server.Internal.ConfigTypes ) where -import Crypto.JOSE as Jose -import Crypto.JWT as Jose +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose import qualified Data.ByteString as BS import Data.Default.Class import Data.Time import GHC.Generics (Generic) import Servant.API (IsSecure (..)) -data IsMatch = Matches | DoesNotMatch - deriving (Eq, Show, Read, Generic, Ord) - data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect deriving (Eq, Show, Read, Generic, Ord) @@ -35,9 +32,8 @@ data JWTSettings jwtAlg :: Maybe Jose.Alg, -- | Keys used to validate JWT. validationKeys :: IO Jose.JWKSet, - -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the - -- intended recipient of the JWT. - audienceMatches :: Jose.StringOrURI -> IsMatch + -- | The validation settings. + validationSettings :: Jose.JWTValidationSettings } deriving (Generic) @@ -48,7 +44,7 @@ defaultJWTSettings k = { signingKey = k, jwtAlg = Nothing, validationKeys = pure $ Jose.JWKSet [k], - audienceMatches = const Matches + validationSettings = Jose.defaultJWTValidationSettings $ const True } -- | The policies to use when generating cookies. @@ -122,14 +118,3 @@ defaultXsrfCookieSettings = xsrfHeaderName = "X-XSRF-TOKEN", xsrfExcludeGet = False } - ------------------------------------------------------------------------------- --- Internal {{{ - -jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings -jwtSettingsToJwtValidationSettings s = - defaultJWTValidationSettings (toBool <$> audienceMatches s) - where - toBool Matches = True - toBool DoesNotMatch = False --- }}} diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs index 3fffde7..7a1aa80 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs @@ -42,7 +42,7 @@ cookieAuthCheck ccfg jwtCfg = do verifiedJWT <- liftIO $ runExceptT $ do unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict jwtCookie valKeys <- liftIO $ validationKeys jwtCfg - Jose.verifyClaims (jwtSettingsToJwtValidationSettings jwtCfg) + Jose.verifyClaims (validationSettings jwtCfg) valKeys unverifiedJWT case verifiedJWT of diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs index afc09fe..e4bd550 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs @@ -30,7 +30,7 @@ jwtAuthCheck config = do unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict token valKeys <- liftIO $ validationKeys config Jose.verifyClaims - (jwtSettingsToJwtValidationSettings config) + (validationSettings config) valKeys unverifiedJWT case verifiedJWT of diff --git a/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth-server/test/Servant/Auth/ServerSpec.hs index cd0f7ba..26fc3e5 100644 --- a/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -16,6 +16,7 @@ import Crypto.JOSE (Alg (HS256, None), Error, import Crypto.JWT (Audience (..), ClaimsSet, NumericDate (NumericDate), SignedJWT, + audiencePredicate, claimAud, claimNbf, signClaims, emptyClaimsSet, @@ -447,8 +448,11 @@ xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting jwtCfg :: JWTSettings -jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x -> - if x == "boo" then DoesNotMatch else Matches } +jwtCfg = + let def = defaultJWTSettings theKey + aud x = x /= "boo" + in def { validationSettings = validationSettings def & audiencePredicate .~ aud } + instance FromBasicAuthData User where fromBasicAuthData (BasicAuthData usr pwd) _