diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,7 +5,9 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [PVP Versioning](https://pvp.haskell.org/). -## [Unreleased] +## [0.4.9.1] - 2025-07-03 + +- Use data-default instead of data-default-class [#1796](https://github.com/haskell-servant/servant/pull/1796) ## [0.4.9.0] - 2024-08-28 - Allow newer versions dependencies, and newer versions of GHC. [#1747](https://github.com/haskell-servant/servant/pull/1747) among others. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/servant-auth-server.cabal b/servant-auth-server.cabal --- a/servant-auth-server.cabal +++ b/servant-auth-server.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: servant-auth-server -version: 0.4.9.0 +version: 0.4.9.1 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server. @@ -16,7 +16,7 @@ copyright: (c) Julian K. Arni license: BSD-3-Clause license-file: LICENSE -tested-with: GHC==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4, GHC ==9.10.1 +tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 build-type: Simple extra-source-files: CHANGELOG.md @@ -31,14 +31,14 @@ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators ghc-options: -Wall build-depends: - base >= 4.14 && < 4.21 + base >= 4.16.4.0 && < 4.22 , aeson >= 1.0.0.1 && < 3 , base64-bytestring >= 1.0.0.1 && < 2 , blaze-builder >= 0.4.1.0 && < 0.5 - , bytestring >= 0.10.6.0 && < 0.13 + , bytestring >= 0.11 && < 0.13 , case-insensitive >= 1.2.0.11 && < 1.3 , cookie >= 0.4.4 && < 0.6 - , data-default-class >= 0.1.2.0 && < 0.2 + , data-default >= 0.2 && < 0.9 , entropy >= 0.4.1.3 && < 0.5 , http-types >= 0.12.2 && < 0.13 , jose >= 0.10 && < 0.12 @@ -51,7 +51,7 @@ , servant-server >= 0.20.2 && < 0.21 , tagged >= 0.8.4 && < 0.9 , text >= 1.2.3.0 && < 2.2 - , time >= 1.5.0.1 && < 1.13 + , time >= 1.5.0.1 && < 1.15 , unordered-containers >= 0.2.9.0 && < 0.3 , wai >= 3.2.1.2 && < 3.3 diff --git a/src/Servant/Auth/Server.hs b/src/Servant/Auth/Server.hs --- a/src/Servant/Auth/Server.hs +++ b/src/Servant/Auth/Server.hs @@ -1,92 +1,96 @@ 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]) + ( -- | 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(..) + -- * 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 + + -- | 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(..) + -- ** Classes + , FromJWT (..) + , ToJWT (..) - -- ** Related types - , IsMatch(..) + -- ** Related types + , IsMatch (..) - -- ** Settings - , JWTSettings(..) + -- ** Settings + , JWTSettings (..) , defaultJWTSettings - -- ** Create check + -- ** Create check , jwtAuthCheck + ---------------------------------------------------------------------------- + -- * Cookie - ---------------------------------------------------------------------------- - -- * Cookie - -- | Cookies are also a method of identifying and authenticating a user. They - -- are particular common when the client is a browser + -- | 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' + -- ** Combinator + + -- | Re-exported from 'servant-auth' , Cookie - -- ** Settings - , CookieSettings(..) - , XsrfCookieSettings(..) + -- ** Settings + , CookieSettings (..) + , XsrfCookieSettings (..) , defaultCookieSettings , defaultXsrfCookieSettings , makeSessionCookie @@ -98,34 +102,35 @@ , acceptLogin , clearSession - - -- ** Related types - , IsSecure(..) - , SameSite(..) + -- ** Related types + , IsSecure (..) + , SameSite (..) , AreAuths - ---------------------------------------------------------------------------- - -- * BasicAuth - -- ** Combinator - -- | Re-exported from 'servant-auth' + + -- * BasicAuth + + -- ** Combinator + + -- | Re-exported from 'servant-auth' , BasicAuth - -- ** Classes - , FromBasicAuthData(..) + -- ** Classes + , FromBasicAuthData (..) - -- ** Settings + -- ** Settings , BasicAuthCfg - -- ** Related types - , BasicAuthData(..) - , IsPasswordCorrect(..) + -- ** Related types + , BasicAuthData (..) + , IsPasswordCorrect (..) - -- ** Authentication request + -- ** Authentication request , wwwAuthenticatedErr - ---------------------------------------------------------------------------- - -- * Utilies - , ThrowAll(throwAll) + + -- * Utilies + , ThrowAll (throwAll) , generateKey , generateSecret , fromSecret @@ -134,17 +139,22 @@ , makeJWT , verifyJWT - -- ** Re-exports - , Default(def) + -- ** Re-exports + , Default (def) , SetCookie - ) where + ) +where -import Prelude hiding (readFile, writeFile) -import Data.ByteString (ByteString, writeFile, readFile) -import Data.Default.Class (Default (def)) +import Crypto.JOSE as Jose +import Data.ByteString (ByteString, readFile, writeFile) +import Data.Default (Default (def)) +import Servant (BasicAuthData (..)) import Servant.Auth import Servant.Auth.JWT -import Servant.Auth.Server.Internal () +import Web.Cookie (SetCookie) +import Prelude hiding (readFile, writeFile) + +import Servant.Auth.Server.Internal () import Servant.Auth.Server.Internal.BasicAuth import Servant.Auth.Server.Internal.Class import Servant.Auth.Server.Internal.ConfigTypes @@ -152,10 +162,6 @@ 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) -- | Generate a key suitable for use with 'defaultConfig'. generateKey :: IO Jose.JWK diff --git a/src/Servant/Auth/Server/Internal.hs b/src/Servant/Auth/Server/Internal.hs --- a/src/Servant/Auth/Server/Internal.hs +++ b/src/Servant/Auth/Server/Internal.hs @@ -4,41 +4,45 @@ module Servant.Auth.Server.Internal where -import Control.Monad.Trans (liftIO) -import Servant ((:>), Handler, HasServer (..), - Proxy (..), - HasContextEntry(getContextEntry)) -import Servant.Auth -import Servant.Auth.JWT (ToJWT) +import Control.Monad.Trans (liftIO) +import Servant + ( Handler + , HasContextEntry (getContextEntry) + , HasServer (..) + , Proxy (..) + , (:>) + ) +import Servant.Auth +import Servant.Auth.JWT (ToJWT) +import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest) 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.Cookie import Servant.Auth.Server.Internal.JWT import Servant.Auth.Server.Internal.Types -import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest) - -instance ( n ~ 'S ('S 'Z) - , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v - , HasServer api ctxs -- this constraint is needed to implement hoistServer - , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler) - , ToJWT v - , HasContextEntry ctxs CookieSettings - , HasContextEntry ctxs JWTSettings - ) => HasServer (Auth auths v :> api) ctxs where +instance + ( -- this constraint is needed to implement hoistServer + AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler) + , AreAuths auths ctxs v + , HasContextEntry ctxs CookieSettings + , HasContextEntry ctxs JWTSettings + , HasServer (AddSetCookiesApi n api) ctxs + , HasServer api ctxs + , ToJWT v + , n ~ 'S ('S 'Z) + ) + => HasServer (Auth auths v :> api) ctxs + where type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m -#if MIN_VERSION_servant_server(0,12,0) - hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -#endif - route _ context subserver = - route (Proxy :: Proxy (AddSetCookiesApi n api)) - context - (fmap go subserver `addAuthCheck` authCheck) - + route + (Proxy :: Proxy (AddSetCookiesApi n api)) + context + (fmap go subserver `addAuthCheck` authCheck) where authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))) authCheck = withRequest $ \req -> liftIO $ do @@ -61,7 +65,12 @@ return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil) _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil) - go :: (AuthResult v -> ServerT api Handler) - -> (AuthResult v, SetCookieList n) - -> ServerT (AddSetCookiesApi n api) Handler + go + :: (AuthResult v -> ServerT api Handler) + -> (AuthResult v, SetCookieList n) + -> ServerT (AddSetCookiesApi n api) Handler go fn (authResult, cookies) = addSetCookies cookies $ fn authResult + +#if MIN_VERSION_servant_server(0,12,0) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s +#endif diff --git a/src/Servant/Auth/Server/Internal/AddSetCookie.hs b/src/Servant/Auth/Server/Internal/AddSetCookie.hs --- a/src/Servant/Auth/Server/Internal/AddSetCookie.hs +++ b/src/Servant/Auth/Server/Internal/AddSetCookie.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Auth.Server.Internal.AddSetCookie where -import Blaze.ByteString.Builder (toByteString) -import qualified Data.ByteString as BS -import Data.Kind (Type) -import qualified Network.HTTP.Types as HTTP -import Network.Wai (mapResponseHeaders) -import Servant -import Servant.API.Generic -import Servant.Server.Generic -import Web.Cookie +import Blaze.ByteString.Builder (toByteString) +import qualified Data.ByteString as BS +import Data.Kind (Type) +import qualified Network.HTTP.Types as HTTP +import Network.Wai (mapResponseHeaders) +import Servant +import Servant.API.Generic +import Servant.Server.Generic +import Web.Cookie -- What are we doing here? Well, the idea is to add headers to the response, -- but the headers come from the authentication check. In order to do that, we @@ -40,13 +40,16 @@ #endif type family AddSetCookieApi a :: Type + type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b + type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b #if MIN_VERSION_servant_server(0,19,0) type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api) #endif -type instance AddSetCookieApi (Verb method stat ctyps a) - = Verb method stat ctyps (AddSetCookieApiVerb a) +type instance + AddSetCookieApi (Verb method stat ctyps a) = + Verb method stat ctyps (AddSetCookieApiVerb a) #if MIN_VERSION_servant_server(0,18,1) type instance AddSetCookieApi (UVerb method ctyps as) = UVerb method ctyps (MapAddSetCookieApiVerb as) @@ -65,59 +68,69 @@ class AddSetCookies (n :: Nat) orig new where addSetCookies :: SetCookieList n -> orig -> new -instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb - => AddSetCookies ('S n) (a -> oldb) (a -> newb) where +instance + {-# OVERLAPS #-} + AddSetCookies ('S n) oldb newb + => AddSetCookies ('S n) (a -> oldb) (a -> newb) + where addSetCookies cookies oldfn = addSetCookies cookies . oldfn -instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where +instance orig1 ~ orig2 => AddSetCookies 'Z orig1 orig2 where addSetCookies _ = id -instance {-# OVERLAPPABLE #-} - ( Functor m +instance + {-# OVERLAPPABLE #-} + ( AddHeader mods "Set-Cookie" SetCookie cookied new , AddSetCookies n (m old) (m cookied) - , AddHeader mods "Set-Cookie" SetCookie cookied new - ) => AddSetCookies ('S n) (m old) (m new) where + , Functor m + ) + => AddSetCookies ('S n) (m old) (m new) + where addSetCookies (mCookie `SetCookieCons` rest) oldVal = case mCookie of Nothing -> noHeader' <$> addSetCookies rest oldVal Just cookie -> addHeader' cookie <$> addSetCookies rest oldVal -instance {-# OVERLAPS #-} +instance + {-# OVERLAPS #-} (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b') - => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where + => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') + where addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b -instance {-# OVERLAPPING #-} +instance + {-# OVERLAPPING #-} (AddSetCookies ('S n) a a, AddSetCookies ('S n) b b') - => AddSetCookies ('S n) (a :<|> b) (a :<|> b') where - addSetCookies cookies ( a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b + => AddSetCookies ('S n) (a :<|> b) (a :<|> b') + where + addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b -instance {-# OVERLAPS #-} +instance + {-# OVERLAPS #-} ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi - , Generic (api (AsServerT m)) , GServantProduct (Rep (api (AsServerT m))) + , Generic (api (AsServerT m)) , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m ) - => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where + => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi + where addSetCookies cookies = addSetCookies cookies . toServant -- | for @servant <0.11@ -instance - AddSetCookies ('S n) Application Application where - addSetCookies cookies r request respond - = r request $ respond . mapResponseHeaders (++ mkHeaders cookies) +instance AddSetCookies ('S n) Application Application where + addSetCookies cookies r request respond = + r request $ respond . mapResponseHeaders (++ mkHeaders cookies) -- | for @servant >=0.11@ -instance - AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where +instance AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where addSetCookies cookies r = Tagged $ \request respond -> unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies) mkHeaders :: SetCookieList x -> [HTTP.Header] mkHeaders x = ("Set-Cookie",) <$> mkCookies x where - mkCookies :: forall y. SetCookieList y -> [BS.ByteString] - mkCookies SetCookieNil = [] - mkCookies (SetCookieCons Nothing rest) = mkCookies rest - mkCookies (SetCookieCons (Just y) rest) - = toByteString (renderSetCookie y) : mkCookies rest + mkCookies :: forall y. SetCookieList y -> [BS.ByteString] + mkCookies SetCookieNil = [] + mkCookies (SetCookieCons Nothing rest) = mkCookies rest + mkCookies (SetCookieCons (Just y) rest) = + toByteString (renderSetCookie y) : mkCookies rest diff --git a/src/Servant/Auth/Server/Internal/BasicAuth.hs b/src/Servant/Auth/Server/Internal/BasicAuth.hs --- a/src/Servant/Auth/Server/Internal/BasicAuth.hs +++ b/src/Servant/Auth/Server/Internal/BasicAuth.hs @@ -1,15 +1,14 @@ {-# LANGUAGE CPP #-} + module Servant.Auth.Server.Internal.BasicAuth where #if !MIN_VERSION_servant_server(0,16,0) #define ServerError ServantErr #endif -import qualified Data.ByteString as BS -import Servant (BasicAuthData (..), - ServerError (..), err401) -import Servant.Server.Internal.BasicAuth (decodeBAHdr, - mkBAChallengerHdr) +import qualified Data.ByteString as BS +import Servant (BasicAuthData (..), ServerError (..), err401) +import Servant.Server.Internal.BasicAuth (decodeBAHdr, mkBAChallengerHdr) import Servant.Auth.Server.Internal.Types @@ -17,28 +16,28 @@ -- Authentication, should be invoked by an application whenever -- appropriate. The argument is the realm. wwwAuthenticatedErr :: BS.ByteString -> ServerError -wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] } +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 diff --git a/src/Servant/Auth/Server/Internal/Class.hs b/src/Servant/Auth/Server/Internal/Class.hs --- a/src/Servant/Auth/Server/Internal/Class.hs +++ b/src/Servant/Auth/Server/Internal/Class.hs @@ -1,23 +1,24 @@ {-# LANGUAGE UndecidableInstances #-} + module Servant.Auth.Server.Internal.Class where -import Servant.Auth -import Data.Kind (Type) +import Data.Kind (Type) import Data.Monoid import Servant hiding (BasicAuth) - +import Servant.Auth import Servant.Auth.JWT -import Servant.Auth.Server.Internal.Types -import Servant.Auth.Server.Internal.ConfigTypes + import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.ConfigTypes import Servant.Auth.Server.Internal.Cookie import Servant.Auth.Server.Internal.JWT (jwtAuthCheck) +import Servant.Auth.Server.Internal.Types -- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all -- elements of @ctx@ to be the in the Context and whose authentication check -- returns an @AuthCheck v@. -class IsAuth a v where - type family AuthArgs a :: [Type] +class IsAuth a v where + type AuthArgs a :: [Type] runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) instance FromJWT usr => IsAuth Cookie usr where @@ -37,19 +38,24 @@ class AreAuths (as :: [Type]) (ctxs :: [Type]) v where runAuths :: proxy as -> Context ctxs -> AuthCheck v -instance AreAuths '[] ctxs v where +instance AreAuths '[] ctxs v where runAuths _ _ = mempty -instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) - , IsAuth a v - , AreAuths as ctxs v - , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) - ) => AreAuths (a ': as) ctxs v where +instance + ( AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) + , AreAuths as ctxs v + , AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) + , IsAuth a v + ) + => AreAuths (a ': as) ctxs v + where runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs where - go = appCtx (Proxy :: Proxy (AuthArgs a)) - ctxs - (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v)) + go = + appCtx + (Proxy :: Proxy (AuthArgs a)) + ctxs + (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v)) type family Unapp ls res where Unapp '[] res = res @@ -64,9 +70,12 @@ class AppCtx ctx ls res where appCtx :: proxy ls -> Context ctx -> res -> App ls res -instance ( HasContextEntry ctxs ctx - , AppCtx ctxs rest res - ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where +instance + ( AppCtx ctxs rest res + , HasContextEntry ctxs ctx + ) + => AppCtx ctxs (ctx ': rest) (ctx -> res) + where appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx instance AppCtx ctx '[] res where diff --git a/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/src/Servant/Auth/Server/Internal/ConfigTypes.hs --- a/src/Servant/Auth/Server/Internal/ConfigTypes.hs +++ b/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -1,21 +1,22 @@ module Servant.Auth.Server.Internal.ConfigTypes ( module Servant.Auth.Server.Internal.ConfigTypes - , Servant.API.IsSecure(..) - ) where + , 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 +import Data.Time +import GHC.Generics (Generic) +import Servant.API (IsSecure (..)) data IsMatch = Matches | DoesNotMatch - deriving (Eq, Show, Read, Generic, Ord) + deriving (Eq, Generic, Ord, Read, Show) data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect - deriving (Eq, Show, Read, Generic, Ord) + deriving (Eq, Generic, Ord, Read, Show) -- The @SameSite@ attribute of cookies determines whether cookies will be sent -- on cross-origin requests. @@ -23,29 +24,31 @@ -- See -- for more information. data SameSite = AnySite | SameSiteStrict | SameSiteLax - deriving (Eq, Show, Read, Generic, Ord) + deriving (Eq, Generic, Ord, Read, Show) -- | @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 :: IO Jose.JWKSet - -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the - -- intended recipient of the JWT. + { signingKey :: Jose.JWK + -- ^ Key used to sign JWT. + , jwtAlg :: Maybe Jose.Alg + -- ^ Algorithm used to sign JWT. + , validationKeys :: IO Jose.JWKSet + -- ^ Keys used to validate JWT. , audienceMatches :: Jose.StringOrURI -> IsMatch - } deriving (Generic) + -- ^ An @aud@ predicate. The @aud@ is a string or URI that identifies the + -- intended recipient of the JWT. + } + deriving (Generic) -- | A @JWTSettings@ where the audience always matches. defaultJWTSettings :: Jose.JWK -> JWTSettings -defaultJWTSettings k = JWTSettings - { signingKey = k - , jwtAlg = Nothing - , validationKeys = pure $ 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. -- @@ -56,72 +59,75 @@ -- 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: + { cookieIsSecure :: !IsSecure + -- ^ '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. + , cookieMaxAge :: !(Maybe DiffTime) + -- ^ How long from now until the cookie expires. Default: @Nothing@. + , cookieExpires :: !(Maybe UTCTime) + -- ^ At what time the cookie expires. Default: @Nothing@. + , cookiePath :: !(Maybe BS.ByteString) + -- ^ The URL path and sub-paths for which this cookie is used. Default: @Just "/"@. + , cookieDomain :: !(Maybe BS.ByteString) + -- ^ Domain name, if set cookie also allows subdomains. Default: @Nothing@. + , cookieSameSite :: !SameSite + -- ^ 'SameSite' settings. Default: @SameSiteLax@. , sessionCookieName :: !BS.ByteString - -- | The optional settings to use for XSRF protection. Default: @Just def@. + -- ^ What name to use for the cookie used for the session. , cookieXsrfSetting :: !(Maybe XsrfCookieSettings) - } deriving (Eq, Show, Generic) + -- ^ The optional settings to use for XSRF protection. Default: @Just def@. + } + deriving (Eq, Generic, Show) instance Default CookieSettings where def = defaultCookieSettings defaultCookieSettings :: CookieSettings -defaultCookieSettings = CookieSettings - { cookieIsSecure = Secure - , cookieMaxAge = Nothing - , cookieExpires = Nothing - , cookiePath = Just "/" - , cookieDomain = Nothing - , cookieSameSite = SameSiteLax +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 "/"@. + { xsrfCookieName :: !BS.ByteString + -- ^ What name to use for the cookie used for XSRF protection. , xsrfCookiePath :: !(Maybe BS.ByteString) - -- | What name to use for the header used for XSRF protection. + -- ^ What path to use for the cookie used for XSRF protection. Default @Just "/"@. , xsrfHeaderName :: !BS.ByteString - -- | Exclude GET request method from XSRF protection. + -- ^ What name to use for the header used for XSRF protection. , xsrfExcludeGet :: !Bool - } deriving (Eq, Show, Generic) + -- ^ Exclude GET request method from XSRF protection. + } + deriving (Eq, Generic, Show) 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/src/Servant/Auth/Server/Internal/Cookie.hs b/src/Servant/Auth/Server/Internal/Cookie.hs --- a/src/Servant/Auth/Server/Internal/Cookie.hs +++ b/src/Servant/Auth/Server/Internal/Cookie.hs @@ -1,31 +1,31 @@ {-# LANGUAGE CPP #-} + module Servant.Auth.Server.Internal.Cookie where -import Blaze.ByteString.Builder (toByteString) -import Control.Monad (MonadPlus(..), guard) -import Control.Monad.Except -import Control.Monad.Reader -import Data.ByteArray (constEq) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as BS64 -import qualified Data.ByteString.Lazy as BSL -import Data.CaseInsensitive (mk) -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day(..)) -import Data.Time.Clock (UTCTime(..), secondsToDiffTime) -import Network.HTTP.Types (methodGet) -import Network.HTTP.Types.Header(hCookie) -import Network.Wai (Request, requestHeaders, requestMethod) -import Servant (AddHeader, addHeader') -import System.Entropy (getEntropy) -import Web.Cookie +import Blaze.ByteString.Builder (toByteString) +import Control.Monad (MonadPlus (..), guard) +import Control.Monad.Except +import Control.Monad.Reader +import Data.ByteArray (constEq) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS64 +import qualified Data.ByteString.Lazy as BSL +import Data.CaseInsensitive (mk) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day (..)) +import Data.Time.Clock (UTCTime (..), secondsToDiffTime) +import Network.HTTP.Types (methodGet) +import Network.HTTP.Types.Header (hCookie) +import Network.Wai (Request, requestHeaders, requestMethod) +import Servant (AddHeader, addHeader') +import Servant.Auth.JWT (FromJWT, ToJWT) +import System.Entropy (getEntropy) +import Web.Cookie -import Servant.Auth.JWT (FromJWT, ToJWT) import Servant.Auth.Server.Internal.ConfigTypes -import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT) +import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT) import Servant.Auth.Server.Internal.Types - cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr cookieAuthCheck ccfg jwtSettings = do req <- ask @@ -45,10 +45,10 @@ xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings xsrfCheckRequired cookieSettings req = do - xsrfCookieCfg <- cookieXsrfSetting cookieSettings - let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet - guard $ not disableForGetReq - return xsrfCookieCfg + xsrfCookieCfg <- cookieXsrfSetting cookieSettings + let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet + guard $ not disableForGetReq + return xsrfCookieCfg xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do @@ -60,52 +60,52 @@ makeXsrfCookie :: CookieSettings -> IO SetCookie makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings - Nothing -> return $ noXsrfTokenCookie cookieSettings + Nothing -> return $ noXsrfTokenCookie cookieSettings where makeRealCookie xsrfCookieSettings = do xsrfValue <- BS64.encode <$> getEntropy 32 - return - $ applyXsrfCookieSettings xsrfCookieSettings - $ applyCookieSettings cookieSettings - $ def{ setCookieValue = xsrfValue } - + return $ + applyXsrfCookieSettings xsrfCookieSettings $ + applyCookieSettings cookieSettings $ + def{setCookieValue = xsrfValue} -- | Alias for 'makeXsrfCookie'. makeCsrfCookie :: CookieSettings -> IO SetCookie makeCsrfCookie = makeXsrfCookie {-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-} - -- | Makes a cookie with session information. makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) makeSessionCookie cookieSettings jwtSettings v = do ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings) case ejwt of Left _ -> return Nothing - Right jwt -> return - $ Just - $ applySessionCookieSettings cookieSettings - $ applyCookieSettings cookieSettings - $ def{ setCookieValue = BSL.toStrict jwt } + Right jwt -> + return $ + Just $ + applySessionCookieSettings cookieSettings $ + applyCookieSettings cookieSettings $ + def{setCookieValue = BSL.toStrict jwt} noXsrfTokenCookie :: CookieSettings -> SetCookie noXsrfTokenCookie cookieSettings = - applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" } + applyCookieSettings cookieSettings $ def{setCookieName = "NO-XSRF-TOKEN", setCookieValue = ""} applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie -applyCookieSettings cookieSettings setCookie = setCookie - { setCookieMaxAge = cookieMaxAge cookieSettings - , setCookieExpires = cookieExpires cookieSettings - , setCookiePath = cookiePath cookieSettings - , setCookieDomain = cookieDomain cookieSettings - , setCookieSecure = case cookieIsSecure cookieSettings of - Secure -> True - NotSecure -> False - , setCookieSameSite = case cookieSameSite cookieSettings of - AnySite -> anySite - SameSiteStrict -> Just sameSiteStrict - SameSiteLax -> Just sameSiteLax - } +applyCookieSettings cookieSettings setCookie = + setCookie + { setCookieMaxAge = cookieMaxAge cookieSettings + , setCookieExpires = cookieExpires cookieSettings + , setCookiePath = cookiePath cookieSettings + , setCookieDomain = cookieDomain cookieSettings + , setCookieSecure = case cookieIsSecure cookieSettings of + Secure -> True + NotSecure -> False + , setCookieSameSite = case cookieSameSite cookieSettings of + AnySite -> anySite + SameSiteStrict -> Just sameSiteStrict + SameSiteLax -> Just sameSiteLax + } where #if MIN_VERSION_cookie(0,4,5) anySite = Just sameSiteNone @@ -114,32 +114,36 @@ #endif applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie -applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie - { setCookieName = xsrfCookieName xsrfCookieSettings - , setCookiePath = xsrfCookiePath xsrfCookieSettings - , setCookieHttpOnly = False - } +applyXsrfCookieSettings xsrfCookieSettings setCookie = + setCookie + { setCookieName = xsrfCookieName xsrfCookieSettings + , setCookiePath = xsrfCookiePath xsrfCookieSettings + , setCookieHttpOnly = False + } applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie -applySessionCookieSettings cookieSettings setCookie = setCookie - { setCookieName = sessionCookieName cookieSettings - , setCookieHttpOnly = True - } +applySessionCookieSettings cookieSettings setCookie = + setCookie + { setCookieName = sessionCookieName cookieSettings + , setCookieHttpOnly = True + } -- | For a JWT-serializable session, returns a function that decorates a -- provided response object with XSRF and session cookies. This should be used -- when a user successfully authenticates with credentials. -acceptLogin :: ( ToJWT session - , AddHeader mods "Set-Cookie" SetCookie response withOneCookie - , AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies ) - => CookieSettings - -> JWTSettings - -> session - -> IO (Maybe (response -> withTwoCookies)) +acceptLogin + :: ( AddHeader mods "Set-Cookie" SetCookie response withOneCookie + , AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies + , ToJWT session + ) + => CookieSettings + -> JWTSettings + -> session + -> IO (Maybe (response -> withTwoCookies)) acceptLogin cookieSettings jwtSettings session = do mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session case mSessionCookie of - Nothing -> pure Nothing + Nothing -> pure Nothing Just sessionCookie -> do xsrfCookie <- makeXsrfCookie cookieSettings return $ Just $ addHeader' sessionCookie . addHeader' xsrfCookie @@ -150,25 +154,28 @@ -- | Adds headers to a response that clears all session cookies -- | using max-age and expires cookie attributes. -clearSession :: ( AddHeader mods "Set-Cookie" SetCookie response withOneCookie - , AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies ) - => CookieSettings - -> response - -> withTwoCookies +clearSession + :: ( AddHeader mods "Set-Cookie" SetCookie response withOneCookie + , AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies + ) + => CookieSettings + -> response + -> withTwoCookies clearSession cookieSettings = addHeader' clearedSessionCookie . addHeader' clearedXsrfCookie where -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both - cookieSettingsExpires = cookieSettings - { cookieExpires = Just expireTime - , cookieMaxAge = Just (secondsToDiffTime 0) - } + cookieSettingsExpires = + cookieSettings + { cookieExpires = Just expireTime + , cookieMaxAge = Just (secondsToDiffTime 0) + } clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def clearedXsrfCookie = case cookieXsrfSetting cookieSettings of - Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def - Nothing -> noXsrfTokenCookie cookieSettingsExpires + Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def + Nothing -> noXsrfTokenCookie cookieSettingsExpires makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) -makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c +makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c -- | Alias for 'makeSessionCookie'. makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) diff --git a/src/Servant/Auth/Server/Internal/FormLogin.hs b/src/Servant/Auth/Server/Internal/FormLogin.hs --- a/src/Servant/Auth/Server/Internal/FormLogin.hs +++ b/src/Servant/Auth/Server/Internal/FormLogin.hs @@ -1,3 +1,1 @@ module Servant.Auth.Server.Internal.FormLogin where - - diff --git a/src/Servant/Auth/Server/Internal/JWT.hs b/src/Servant/Auth/Server/Internal/JWT.hs --- a/src/Servant/Auth/Server/Internal/JWT.hs +++ b/src/Servant/Auth/Server/Internal/JWT.hs @@ -1,22 +1,21 @@ module Servant.Auth.Server.Internal.JWT where -import Control.Lens -import Control.Monad (MonadPlus(..), guard) -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 Control.Lens +import Control.Monad (MonadPlus (..), guard) +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 Data.Maybe (fromMaybe) -import Data.Time (UTCTime) -import Network.Wai (requestHeaders) +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime) +import Network.Wai (requestHeaders) +import Servant.Auth.JWT (FromJWT (..), ToJWT (..)) -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 @@ -36,21 +35,26 @@ -- | 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 = Jose.runJOSE $ 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 verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a) verifyJWT jwtCfg input = do diff --git a/src/Servant/Auth/Server/Internal/ThrowAll.hs b/src/Servant/Auth/Server/Internal/ThrowAll.hs --- a/src/Servant/Auth/Server/Internal/ThrowAll.hs +++ b/src/Servant/Auth/Server/Internal/ThrowAll.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} + module Servant.Auth.Server.Internal.ThrowAll where #if !MIN_VERSION_servant_server(0,16,0) @@ -7,15 +8,14 @@ #endif import Control.Monad.Error.Class -import Data.Tagged (Tagged (..)) -import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..)) -import Servant.API.Generic -import Servant.Server.Generic -import Servant.Server +import qualified Data.ByteString.Char8 as BS +import Data.Tagged (Tagged (..)) import Network.HTTP.Types import Network.Wai - -import qualified Data.ByteString.Char8 as BS +import Servant (NamedRoutes (..), ServerError (..), (:<|>) (..)) +import Servant.API.Generic +import Servant.Server +import Servant.Server.Generic class ThrowAll a where -- | 'throwAll' is a convenience function to throw errors across an entire @@ -30,9 +30,9 @@ throwAll e = throwAll e :<|> throwAll e instance - ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) => - ThrowAll (api (AsServerT m)) where - + (GenericServant api (AsServerT m), ThrowAll (ToServant api (AsServerT m))) + => ThrowAll (api (AsServerT m)) + where throwAll = fromServant . throwAll -- Really this shouldn't be necessary - ((->) a) should be an instance of @@ -40,19 +40,23 @@ instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where throwAll e = const $ throwAll e -instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where +instance {-# OVERLAPPABLE #-} MonadError ServerError m => ThrowAll (m a) where throwAll = throwError -- | for @servant <0.11@ instance {-# OVERLAPPING #-} ThrowAll Application where - throwAll e _req respond - = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) - (errHeaders e) - (errBody e) + throwAll e _req respond = + respond $ + responseLBS + (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) + (errHeaders e) + (errBody e) -- | for @servant >=0.11@ instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where throwAll e = Tagged $ \_req respond -> - respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) - (errHeaders e) - (errBody e) + respond $ + responseLBS + (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) + (errHeaders e) + (errBody e) diff --git a/src/Servant/Auth/Server/Internal/Types.hs b/src/Servant/Auth/Server/Internal/Types.hs --- a/src/Servant/Auth/Server/Internal/Types.hs +++ b/src/Servant/Auth/Server/Internal/Types.hs @@ -1,34 +1,34 @@ {-# LANGUAGE CPP #-} + module Servant.Auth.Server.Internal.Types where import Control.Applicative -import Control.Monad (MonadPlus(..), ap) +import Control.Monad (MonadPlus (..), ap) +import qualified Control.Monad.Fail as Fail import Control.Monad.Reader import Control.Monad.Time -import Data.Monoid (Monoid (..)) -import Data.Semigroup (Semigroup (..)) -import Data.Time (getCurrentTime) -import GHC.Generics (Generic) -import Network.Wai (Request) - -import qualified Control.Monad.Fail as Fail +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Time (getCurrentTime) +import GHC.Generics (Generic) +import Network.Wai (Request) -- | The result of an authentication attempt. data AuthResult val = BadPassword | NoSuchUser - -- | Authentication succeeded. - | Authenticated val - -- | If an authentication procedure cannot be carried out - if for example it - -- expects a password and username in a header that is not present - - -- @Indefinite@ is returned. This indicates that other authentication - -- methods should be tried. - | Indefinite - deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable) + | -- | Authentication succeeded. + Authenticated val + | -- | If an authentication procedure cannot be carried out - if for example it + -- expects a password and username in a header that is not present - + -- @Indefinite@ is returned. This indicates that other authentication + -- methods should be tried. + Indefinite + deriving (Eq, Foldable, Functor, Generic, Ord, Read, Show, Traversable) instance Semigroup (AuthResult val) where Indefinite <> y = y - x <> _ = x + x <> _ = x instance Monoid (AuthResult val) where mempty = Indefinite @@ -41,9 +41,9 @@ instance Monad AuthResult where return = Authenticated Authenticated v >>= f = f v - BadPassword >>= _ = BadPassword - NoSuchUser >>= _ = NoSuchUser - Indefinite >>= _ = Indefinite + BadPassword >>= _ = BadPassword + NoSuchUser >>= _ = NoSuchUser + Indefinite >>= _ = Indefinite instance Alternative AuthResult where empty = mzero @@ -53,14 +53,13 @@ mzero = mempty mplus = (<>) - -- | An @AuthCheck@ is the function used to decide the authentication status -- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a -- Monoid or Alternative; the semantics of this is that the *first* -- non-'Indefinite' result from left to right is used and the rest are ignored. newtype AuthCheck val = AuthCheck - { runAuthCheck :: Request -> IO (AuthResult val) } - deriving (Generic, Functor) + {runAuthCheck :: Request -> IO (AuthResult val)} + deriving (Functor, Generic) instance Semigroup (AuthCheck val) where AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do @@ -83,9 +82,9 @@ aresult <- ac req case aresult of Authenticated usr -> runAuthCheck (f usr) req - BadPassword -> return BadPassword - NoSuchUser -> return NoSuchUser - Indefinite -> return Indefinite + BadPassword -> return BadPassword + NoSuchUser -> return NoSuchUser + Indefinite -> return Indefinite #if !MIN_VERSION_base(4,13,0) fail = Fail.fail diff --git a/src/Servant/Auth/Server/SetCookieOrphan.hs b/src/Servant/Auth/Server/SetCookieOrphan.hs --- a/src/Servant/Auth/Server/SetCookieOrphan.hs +++ b/src/Servant/Auth/Server/SetCookieOrphan.hs @@ -1,3 +1,4 @@ module Servant.Auth.Server.SetCookieOrphan - {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-} - () where + {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-} + () +where diff --git a/test/Servant/Auth/ServerSpec.hs b/test/Servant/Auth/ServerSpec.hs --- a/test/Servant/Auth/ServerSpec.hs +++ b/test/Servant/Auth/ServerSpec.hs @@ -1,70 +1,90 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} + module Servant.Auth.ServerSpec (spec) where #if !MIN_VERSION_servant_server(0,16,0) #define ServerError ServantErr #endif -import Control.Lens -import Control.Monad.IO.Class (liftIO) -import Crypto.JOSE (Alg (HS256, None), Error, - JWK, JWSHeader, - KeyMaterialGenParam (OctGenParam), - ToCompact, encodeCompact, - genJWK, newJWSHeader, runJOSE) -import Crypto.JWT (Audience (..), ClaimsSet, - NumericDate (NumericDate), - SignedJWT, - claimAud, claimNbf, - signClaims, - emptyClaimsSet, - unregisteredClaims) -import Data.Aeson (FromJSON, ToJSON, Value, - toJSON, encode) -import Data.Aeson.Lens (_JSON) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.Text (Text, pack) -import Data.CaseInsensitive (mk) -import Data.Foldable (find) -import Data.Monoid -import Data.Time -import Data.Time.Clock (getCurrentTime) -import GHC.Generics (Generic) -import Network.HTTP.Client (cookie_http_only, - cookie_name, cookie_value, - cookie_expiry_time, - destroyCookieJar) -import Network.HTTP.Types (Status, status200, - status401) -import Network.Wai (responseLBS) -import Network.Wai.Handler.Warp (testWithApplication) -import Network.Wreq (Options, auth, basicAuth, - checkResponse, - cookieExpiryTime, cookies, - defaults, get, getWith, postWith, - header, oauth2Bearer, - responseBody, - responseCookieJar, - responseHeader, - responseStatus) -import Network.Wreq.Types (Postable(..)) -import Servant hiding (BasicAuth, - IsSecure (..), header) -import Servant.API.Generic ((:-)) -import Servant.Auth.Server -import Servant.Auth.Server.Internal.Cookie (expireTime) -import Servant.Auth.Server.SetCookieOrphan () +import Control.Lens +import Control.Monad.IO.Class (liftIO) +import Crypto.JOSE + ( Alg (HS256, None) + , Error + , JWK + , JWSHeader + , KeyMaterialGenParam (OctGenParam) + , ToCompact + , encodeCompact + , genJWK + , newJWSHeader + , runJOSE + ) +import Crypto.JWT + ( Audience (..) + , ClaimsSet + , NumericDate (NumericDate) + , SignedJWT + , claimAud + , claimNbf + , emptyClaimsSet + , signClaims + , unregisteredClaims + ) +import Data.Aeson (FromJSON, ToJSON, Value, encode, toJSON) +import Data.Aeson.Lens (_JSON) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.CaseInsensitive (mk) +import Data.Foldable (find) +import Data.Monoid +import Data.Text (Text, pack) +import Data.Time +import Data.Time.Clock (getCurrentTime) +import GHC.Generics (Generic) +import Network.HTTP.Client + ( cookie_expiry_time + , cookie_http_only + , cookie_name + , cookie_value + , destroyCookieJar + ) +import Network.HTTP.Types (Status, status200, status401) +import Network.Wai (responseLBS) +import Network.Wai.Handler.Warp (testWithApplication) +import Network.Wreq + ( Options + , auth + , basicAuth + , checkResponse + , cookieExpiryTime + , cookies + , defaults + , get + , getWith + , header + , oauth2Bearer + , postWith + , responseBody + , responseCookieJar + , responseHeader + , responseStatus + ) +import Network.Wreq.Types (Postable (..)) +import Servant hiding (BasicAuth, IsSecure (..), header) +import Servant.API.Generic ((:-)) + +import Servant.Auth.Server +import Servant.Auth.Server.Internal.Cookie (expireTime) +import Servant.Auth.Server.SetCookieOrphan () #if MIN_VERSION_servant_server(0,15,0) -import qualified Servant.Types.SourceT as S +import qualified Servant.Types.SourceT as S #endif -import System.IO.Unsafe (unsafePerformIO) -import Test.Hspec -import Test.QuickCheck import qualified Network.HTTP.Client as HCli - - +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec +import Test.QuickCheck spec :: Spec spec = do @@ -75,333 +95,369 @@ basicAuthSpec ------------------------------------------------------------------------------ + -- * Auth {{{ authSpec :: Spec -authSpec - = describe "The Auth combinator" - $ aroundAll (testWithApplication . return $ app jwtAndCookieApi) $ do - - it "returns a 401 if all authentications are Indefinite" $ \port -> do - get (url port) `shouldHTTPErrorWith` status401 - - it "succeeds if one authentication suceeds" $ \port -> property $ - \(user :: User) -> do - jwt <- makeJWT user jwtCfg Nothing - opts <- addJwtToHeader jwt - resp <- getWith opts (url port) - resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) - - it "fails (403) if one authentication fails" $ const $ - pendingWith "Authentications don't yet fail, only are Indefinite" - - it "doesn't clobber pre-existing response headers" $ \port -> property $ - \(user :: User) -> do - jwt <- makeJWT user jwtCfg Nothing - opts <- addJwtToHeader jwt - resp <- getWith opts (url port ++ "/header") - resp ^. responseHeader "Blah" `shouldBe` "1797" - resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") - - context "Raw" $ do - - it "gets the response body" $ \port -> property $ \(user :: User) -> do - jwt <- makeJWT user jwtCfg Nothing - opts <- addJwtToHeader jwt - resp <- getWith opts (url port ++ "/raw") - resp ^. responseBody `shouldBe` "how are you?" - - it "doesn't clobber pre-existing reponse headers" $ \port -> property $ - \(user :: User) -> do - jwt <- makeJWT user jwtCfg Nothing - opts <- addJwtToHeader jwt - resp <- getWith opts (url port ++ "/raw") - resp ^. responseHeader "hi" `shouldBe` "there" - resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") - - - context "Setting cookies" $ do - - it "sets cookies that it itself accepts" $ \port -> property $ \user -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) - (claims $ toJSON user) - opts' <- addJwtToCookie cookieCfg jwt - let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) - (xsrfField xsrfCookieName cookieCfg <> "=blah") - resp <- getWith opts (url port) - let (cookieJar:_) = resp ^.. responseCookieJar - Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) - $ destroyCookieJar cookieJar - opts2 = defaults - & cookies .~ Just cookieJar - & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf] - resp2 <- getWith opts2 (url port) - resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user) +authSpec = + describe "The Auth combinator" $ + aroundAll (testWithApplication . return $ app jwtAndCookieApi) $ do + it "returns a 401 if all authentications are Indefinite" $ \port -> do + get (url port) `shouldHTTPErrorWith` status401 - it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) - (claims $ toJSON user) - opts' <- addJwtToCookie cookieCfg jwt - let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) - (xsrfField xsrfCookieName cookieCfg <> "=blah") - resp <- getWith opts (url port) - let (cookieJar:_) = resp ^.. responseCookieJar - Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) - $ destroyCookieJar cookieJar - xxsrf ^. cookieExpiryTime `shouldBe` future + it "succeeds if one authentication suceeds" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) - it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) - (claims $ toJSON user) - opts' <- addJwtToCookie cookieCfg jwt - let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) - (xsrfField xsrfCookieName cookieCfg <> "=blah") - resp <- getWith opts (url port) - let (cookieJar:_) = resp ^.. responseCookieJar - Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg) - $ destroyCookieJar cookieJar - cookie_http_only token `shouldBe` True + it "fails (403) if one authentication fails" $ + const $ + pendingWith "Authentications don't yet fail, only are Indefinite" + it "doesn't clobber pre-existing response headers" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/header") + resp ^. responseHeader "Blah" `shouldBe` "1797" + resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") + context "Raw" $ do + it "gets the response body" $ \port -> property $ \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/raw") + resp ^. responseBody `shouldBe` "how are you?" --- }}} ------------------------------------------------------------------------------- --- * Cookie Auth {{{ + it "doesn't clobber pre-existing reponse headers" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/raw") + resp ^. responseHeader "hi" `shouldBe` "there" + resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") -cookieAuthSpec :: Spec -cookieAuthSpec - = describe "The Auth combinator" $ do - describe "With XSRF check" $ - aroundAll (testWithApplication . return $ app cookieOnlyApi) $ do + context "Setting cookies" $ do + it "sets cookies that it itself accepts" $ \port -> property $ \user -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = + addCookie + (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar : _) = resp ^.. responseCookieJar + Just xxsrf = + find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) $ + destroyCookieJar cookieJar + opts2 = + defaults + & cookies .~ Just cookieJar + & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf] + resp2 <- getWith opts2 (url port) + resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user) - it "fails if XSRF header and cookie don't match" $ \port -> property - $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), HS256)) + (claims $ toJSON user) opts' <- addJwtToCookie cookieCfg jwt - let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) - (xsrfField xsrfCookieName cookieCfg <> "=blerg") - getWith opts (url port) `shouldHTTPErrorWith` status401 + let opts = + addCookie + (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar : _) = resp ^.. responseCookieJar + Just xxsrf = + find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) $ + destroyCookieJar cookieJar + xxsrf ^. cookieExpiryTime `shouldBe` future - it "fails with no XSRF header or cookie" $ \port -> property - $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), HS256)) + (claims $ toJSON user) opts' <- addJwtToCookie cookieCfg jwt - let opts = opts' & checkResponse .~ Just mempty + let opts = + addCookie + (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") resp <- getWith opts (url port) - resp ^. responseStatus `shouldBe` status401 - (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"] + let (cookieJar : _) = resp ^.. responseCookieJar + Just token = + find (\x -> cookie_name x == sessionCookieName cookieCfg) $ + destroyCookieJar cookieJar + cookie_http_only token `shouldBe` True - -- Validating that the XSRF cookie isn't added for UVerb routes either. - -- These routes can return a 401 response directly without using throwError / throwAll, - -- which revealed a bug: - -- - -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449 - resp <- getWith opts (url port ++ "/uverb") - resp ^. responseStatus `shouldBe` status401 - (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"] +-- }}} +------------------------------------------------------------------------------ +-- * Cookie Auth {{{ - it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property - $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) - opts' <- addJwtToCookie cookieCfg jwt - let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) - (xsrfField xsrfCookieName cookieCfg <> "=blah") - resp <- getWith opts (url port) - resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) +cookieAuthSpec :: Spec +cookieAuthSpec = + describe "The Auth combinator" $ do + describe "With XSRF check" $ + aroundAll (testWithApplication . return $ app cookieOnlyApi) $ do + it "fails if XSRF header and cookie don't match" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = + addCookie + (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blerg") + getWith opts (url port) `shouldHTTPErrorWith` status401 - it "sets and clears the right cookies" $ \port -> property - $ \(user :: User) -> do - let optsFromResp resp = - let jar = resp ^. responseCookieJar - Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar) - in defaults - & cookies .~ Just jar -- real cookie jars aren't updated by being replaced - & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue] + it "fails with no XSRF header or cookie" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = opts' & checkResponse .~ Just mempty + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status401 + (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"] - resp <- postWith defaults (url port ++ "/login") user - (resp ^. responseCookieJar) `shouldMatchCookieNames` - [ sessionCookieName cookieCfg - , xsrfField xsrfCookieName cookieCfg - ] - let loggedInOpts = optsFromResp resp + -- Validating that the XSRF cookie isn't added for UVerb routes either. + -- These routes can return a 401 response directly without using throwError / throwAll, + -- which revealed a bug: + -- + -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449 + resp <- getWith opts (url port ++ "/uverb") + resp ^. responseStatus `shouldBe` status401 + (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"] - resp <- getWith loggedInOpts (url port) - resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = + addCookie + (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) - -- logout - resp <- getWith loggedInOpts (url port ++ "/logout") + it "sets and clears the right cookies" $ \port -> property $ + \(user :: User) -> do + let optsFromResp resp = + let jar = resp ^. responseCookieJar + Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar) + in defaults + & cookies .~ Just jar -- real cookie jars aren't updated by being replaced + & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue] - -- assert cookies were expired - now <- getCurrentTime - let assertCookie c = now >= cookie_expiry_time c - all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + resp <- postWith defaults (url port ++ "/login") user + (resp ^. responseCookieJar) + `shouldMatchCookieNames` [ sessionCookieName cookieCfg + , xsrfField xsrfCookieName cookieCfg + ] + let loggedInOpts = optsFromResp resp - let loggedOutOpts = optsFromResp resp - getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 + resp <- getWith loggedInOpts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) - describe "With no XSRF check for GET requests" $ let - noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True } - cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg } - in aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do + -- logout + resp <- getWith loggedInOpts (url port ++ "/logout") - it "succeeds with no XSRF header or cookie for GET" $ \port -> property - $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) - opts <- addJwtToCookie cookieCfgNoXsrfGet jwt - resp <- getWith opts (url port) - resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True - it "fails with no XSRF header or cookie for POST" $ \port -> property - $ \(user :: User) number -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) - opts <- addJwtToCookie cookieCfgNoXsrfGet jwt - postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401 + let loggedOutOpts = optsFromResp resp + getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 - describe "With no XSRF check at all" $ let - cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing } - in aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do + describe "With no XSRF check for GET requests" $ + let + noXsrfGet xsrfCfg = xsrfCfg{xsrfExcludeGet = True} + cookieCfgNoXsrfGet = cookieCfg{cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg} + in + aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do + it "succeeds with no XSRF header or cookie for GET" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrfGet jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) - it "succeeds with no XSRF header or cookie for GET" $ \port -> property - $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) - opts <- addJwtToCookie cookieCfgNoXsrf jwt - resp <- getWith opts (url port) - resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + it "fails with no XSRF header or cookie for POST" $ \port -> property $ + \(user :: User) number -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrfGet jwt + postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401 - it "succeeds with no XSRF header or cookie for POST" $ \port -> property - $ \(user :: User) number -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) - opts <- addJwtToCookie cookieCfgNoXsrf jwt - resp <- postWith opts (url port) $ toJSON (number :: Int) - resp ^? responseBody . _JSON `shouldBe` Just number + describe "With no XSRF check at all" $ + let + cookieCfgNoXsrf = cookieCfg{cookieXsrfSetting = Nothing} + in + aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do + it "succeeds with no XSRF header or cookie for GET" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrf jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) - it "sets and clears the right cookies" $ \port -> property - $ \(user :: User) -> do - let optsFromResp resp = defaults - & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced + it "succeeds with no XSRF header or cookie for POST" $ \port -> property $ + \(user :: User) number -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrf jwt + resp <- postWith opts (url port) $ toJSON (number :: Int) + resp ^? responseBody . _JSON `shouldBe` Just number - resp <- postWith defaults (url port ++ "/login") user - (resp ^. responseCookieJar) `shouldMatchCookieNames` - [ sessionCookieName cookieCfg - , "NO-XSRF-TOKEN" - ] - let loggedInOpts = optsFromResp resp + it "sets and clears the right cookies" $ \port -> property $ + \(user :: User) -> do + let optsFromResp resp = + defaults + & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced + resp <- postWith defaults (url port ++ "/login") user + (resp ^. responseCookieJar) + `shouldMatchCookieNames` [ sessionCookieName cookieCfg + , "NO-XSRF-TOKEN" + ] + let loggedInOpts = optsFromResp resp - resp <- getWith (loggedInOpts) (url port) - resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + resp <- getWith (loggedInOpts) (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) - resp <- getWith loggedInOpts (url port ++ "/logout") - (resp ^. responseCookieJar) `shouldMatchCookieNameValues` - [ (sessionCookieName cookieCfg, "value") - , ("NO-XSRF-TOKEN", "") - ] + resp <- getWith loggedInOpts (url port ++ "/logout") + (resp ^. responseCookieJar) + `shouldMatchCookieNameValues` [ (sessionCookieName cookieCfg, "value") + , ("NO-XSRF-TOKEN", "") + ] - -- assert cookies were expired - now <- getCurrentTime - let assertCookie c = now >= cookie_expiry_time c - all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True - let loggedOutOpts = optsFromResp resp + let loggedOutOpts = optsFromResp resp - getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 + getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 -- }}} ------------------------------------------------------------------------------ + -- * JWT Auth {{{ jwtAuthSpec :: Spec -jwtAuthSpec - = describe "The JWT combinator" - $ aroundAll (testWithApplication . return $ app jwtOnlyApi) $ do - - it "fails if 'aud' does not match predicate" $ \port -> property $ - \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) - (claims (toJSON user) & claimAud .~ Just (Audience ["boo"])) - opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) - getWith opts (url port) `shouldHTTPErrorWith` status401 +jwtAuthSpec = + describe "The JWT combinator" $ + aroundAll (testWithApplication . return $ app jwtOnlyApi) $ do + it "fails if 'aud' does not match predicate" $ \port -> property $ + \(user :: User) -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["boo"])) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 - it "succeeds if 'aud' does match predicate" $ \port -> property $ - \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) - (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"])) - opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) - resp <- getWith opts (url port) - resp ^. responseStatus `shouldBe` status200 + it "succeeds if 'aud' does match predicate" $ \port -> property $ + \(user :: User) -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"])) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status200 - it "fails if 'nbf' is set to a future date" $ \port -> property $ - \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) - (claims (toJSON user) & claimNbf .~ Just (NumericDate future)) - opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) - getWith opts (url port) `shouldHTTPErrorWith` status401 + it "fails if 'nbf' is set to a future date" $ \port -> property $ + \(user :: User) -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimNbf .~ Just (NumericDate future)) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 - it "fails if 'exp' is set to a past date" $ \port -> property $ - \(user :: User) -> do - jwt <- makeJWT user jwtCfg (Just past) - opts <- addJwtToHeader jwt - getWith opts (url port) `shouldHTTPErrorWith` status401 + it "fails if 'exp' is set to a past date" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg (Just past) + opts <- addJwtToHeader jwt + getWith opts (url port) `shouldHTTPErrorWith` status401 - it "succeeds if 'exp' is set to a future date" $ \port -> property $ - \(user :: User) -> do - jwt <- makeJWT user jwtCfg (Just future) - opts <- addJwtToHeader jwt - resp <- getWith opts (url port) - resp ^. responseStatus `shouldBe` status200 + it "succeeds if 'exp' is set to a future date" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg (Just future) + opts <- addJwtToHeader jwt + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status200 - it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), None)) - (claims $ toJSON user) - opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) - getWith opts (url port) `shouldHTTPErrorWith` status401 + it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), None)) + (claims $ toJSON user) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 - it "fails if JWT does not use expected algorithm" $ const $ - pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19" + it "fails if JWT does not use expected algorithm" $ + const $ + pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19" - it "fails if data is not valid JSON" $ \port -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{") - opts <- addJwtToHeader (jwt >>= (return .encodeCompact)) - getWith opts (url port) `shouldHTTPErrorWith` status401 + it "fails if data is not valid JSON" $ \port -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{") + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 - it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do - jwt <- createJWT theKey (newJWSHeader ((), HS256)) - (claims $ toJSON user) - resp <- case jwt >>= (return . encodeCompact) of - Left (e :: Error) -> fail $ show e - Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port) - resp ^. responseStatus `shouldBe` status200 + it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do + jwt <- + createJWT + theKey + (newJWSHeader ((), HS256)) + (claims $ toJSON user) + resp <- case jwt >>= (return . encodeCompact) of + Left (e :: Error) -> fail $ show e + Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port) + resp ^. responseStatus `shouldBe` status200 -- }}} ------------------------------------------------------------------------------ + -- * Basic Auth {{{ basicAuthSpec :: Spec -basicAuthSpec = describe "The BasicAuth combinator" - $ aroundAll (testWithApplication . return $ app basicAuthApi) $ do - - it "succeeds with the correct password and username" $ \port -> do - resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port) - resp ^. responseStatus `shouldBe` status200 +basicAuthSpec = describe "The BasicAuth combinator" $ + aroundAll (testWithApplication . return $ app basicAuthApi) $ do + it "succeeds with the correct password and username" $ \port -> do + resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port) + resp ^. responseStatus `shouldBe` status200 - it "fails with non-existent user" $ \port -> do - getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port) - `shouldHTTPErrorWith` status401 + it "fails with non-existent user" $ \port -> do + getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port) + `shouldHTTPErrorWith` status401 - it "fails with incorrect password" $ \port -> do - getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port) - `shouldHTTPErrorWith` status401 + it "fails with incorrect password" $ \port -> do + getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port) + `shouldHTTPErrorWith` status401 - it "fails with no auth header" $ \port -> do - get (url port) `shouldHTTPErrorWith` status401 + it "fails with no auth header" $ \port -> do + get (url port) `shouldHTTPErrorWith` status401 -- }}} ------------------------------------------------------------------------------ + -- * ThrowAll {{{ throwAllSpec :: Spec throwAllSpec = describe "throwAll" $ do - it "works for plain values" $ do let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String t = throwAll err401 @@ -415,8 +471,10 @@ -- }}} ------------------------------------------------------------------------------ + -- * API and Server {{{ +{- FOURMOLU_DISABLE -} type API auths = Auth auths User :> ( Get '[JSON] Int @@ -433,10 +491,12 @@ , Header "Set-Cookie" SetCookie ] NoContent) :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie , Header "Set-Cookie" SetCookie ] NoContent) +{- FOURMOLU_ENABLE -} data DummyRoutes mode = DummyRoutes { dummyInt :: mode :- "dummy" :> Get '[JSON] Int - } deriving Generic + } + deriving (Generic) jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) jwtOnlyApi = Proxy @@ -454,64 +514,78 @@ theKey = unsafePerformIO . genJWK $ OctGenParam 256 {-# NOINLINE theKey #-} - cookieCfg :: CookieSettings -cookieCfg = def - { cookieExpires = Just future - , cookieIsSecure = NotSecure - , sessionCookieName = "RuncibleSpoon" - , cookieXsrfSetting = pure $ def - { xsrfCookieName = "TheyDinedOnMince" - , xsrfHeaderName = "AndSlicesOfQuince" +cookieCfg = + def + { cookieExpires = Just future + , cookieIsSecure = NotSecure + , sessionCookieName = "RuncibleSpoon" + , cookieXsrfSetting = + pure $ + def + { xsrfCookieName = "TheyDinedOnMince" + , xsrfHeaderName = "AndSlicesOfQuince" + } } - } + 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 = + (defaultJWTSettings theKey) + { audienceMatches = \x -> + if x == "boo" then DoesNotMatch else Matches + } instance FromBasicAuthData User where - fromBasicAuthData (BasicAuthData usr pwd) _ - = return $ if usr == "ali" && pwd == "Open sesame" - then Authenticated $ User "ali" "ali@the-thieves-den.com" - else Indefinite + fromBasicAuthData (BasicAuthData usr pwd) _ = + return $ + if usr == "ali" && pwd == "Open sesame" + then Authenticated $ User "ali" "ali@the-thieves-den.com" + else Indefinite -- Could be anything, really, but since this is already in the cfg we don't -- have to add it type instance BasicAuthCfg = JWK -appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User - => Proxy (API auths) -> CookieSettings -> Application +appWithCookie + :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User + => Proxy (API auths) + -> CookieSettings + -> Application appWithCookie api ccfg = serveWithContext api ctx $ server ccfg where ctx = ccfg :. jwtCfg :. theKey :. EmptyContext -- | Takes a proxy parameter indicating which authentication systems to enable. -app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User - => Proxy (API auths) -> Application +app + :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User + => Proxy (API auths) + -> Application app api = appWithCookie api cookieCfg +{- FOURMOLU_DISABLE -} server :: CookieSettings -> Server (API auths) server ccfg = - (\authResult -> case authResult of - Authenticated usr -> getInt usr - :<|> postInt usr - :<|> DummyRoutes { dummyInt = getInt usr } - :<|> getHeaderInt + ( \authResult -> case authResult of + Authenticated usr -> + getInt usr + :<|> postInt usr + :<|> DummyRoutes{dummyInt = getInt usr} + :<|> getHeaderInt #if MIN_VERSION_servant_server(0,15,0) - :<|> return (S.source ["bytestring"]) + :<|> return (S.source ["bytestring"]) #endif - :<|> raw - Indefinite -> throwAll err401 - _ -> throwAll err403 - ) :<|> - (\authResult -> case authResult of - Authenticated usr -> respond (WithStatus @200 (42 :: Int)) - Indefinite -> respond (WithStatus @401 $ pack "Authentication required") - _ -> respond (WithStatus @403 $ pack "Forbidden") - ) + :<|> raw + Indefinite -> throwAll err401 + _ -> throwAll err403 + ) + :<|> ( \authResult -> case authResult of + Authenticated usr -> respond (WithStatus @200 (42 :: Int)) + Indefinite -> respond (WithStatus @401 $ pack "Authentication required") + _ -> respond (WithStatus @403 $ pack "Forbidden") + ) :<|> getLogin :<|> getLogout where @@ -524,16 +598,29 @@ getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int) getHeaderInt = return $ addHeader 1797 17 - getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie - , Header "Set-Cookie" SetCookie ] NoContent) + getLogin + :: User + -> Handler + ( Headers + '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie + ] + NoContent + ) getLogin user = do - maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user - case maybeApplyCookies of - Just applyCookies -> return $ applyCookies NoContent - Nothing -> error "cookies failed to apply" + maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user + case maybeApplyCookies of + Just applyCookies -> return $ applyCookies NoContent + Nothing -> error "cookies failed to apply" - getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie - , Header "Set-Cookie" SetCookie ] NoContent) + getLogout + :: Handler + ( Headers + '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie + ] + NoContent + ) getLogout = return $ clearSession ccfg NoContent raw :: Server Raw @@ -543,9 +630,11 @@ #endif \_req respond -> respond $ responseLBS status200 [("hi", "there")] "how are you?" +{- FOURMOLU_ENABLE -} -- }}} ------------------------------------------------------------------------------ + -- * Utils {{{ past :: UTCTime @@ -557,8 +646,9 @@ addJwtToHeader :: Either Error BSL.ByteString -> IO Options addJwtToHeader jwt = case jwt of Left e -> fail $ show e - Right v -> return - $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] + Right v -> + return $ + defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT) createJWT k a b = runJOSE $ signClaims k a b @@ -566,16 +656,19 @@ addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of Left e -> fail $ show e - Right v -> return - $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v] + Right v -> + return $ + defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v] addCookie :: Options -> BS.ByteString -> Options -addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of - [h] -> [cookie' <> "; " <> h] - [] -> [cookie'] - _ -> error "expecting single cookie header" - +addCookie opts cookie' = + opts + & header "Cookie" %~ \c -> case c of + [h] -> [cookie' <> "; " <> h] + [] -> [cookie'] + _ -> error "expecting single cookie header" +{- FOURMOLU_DISABLE -} shouldHTTPErrorWith :: IO a -> Status -> Expectation shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of #if MIN_VERSION_http_client(0,5,0) @@ -585,21 +678,23 @@ HCli.StatusCodeException x _ _ -> x == stat #endif _ -> False +{- FOURMOLU_ENABLE -} shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation -shouldMatchCookieNames cj patterns - = fmap cookie_name (destroyCookieJar cj) +shouldMatchCookieNames cj patterns = + fmap cookie_name (destroyCookieJar cj) `shouldMatchList` patterns shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation shouldNotHaveCookies cj patterns = - sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns - where cookieNames :: [BS.ByteString] - cookieNames = cookie_name <$> destroyCookieJar cj + sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns + where + cookieNames :: [BS.ByteString] + cookieNames = cookie_name <$> destroyCookieJar cj shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation -shouldMatchCookieNameValues cj patterns - = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj) +shouldMatchCookieNameValues cj patterns = + fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj) `shouldMatchList` patterns url :: Int -> String @@ -607,28 +702,35 @@ claims :: Value -> ClaimsSet claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val + -- }}} ------------------------------------------------------------------------------ + -- * Types {{{ data User = User { name :: String - , _id :: String - } deriving (Eq, Show, Read, Generic) + , _id :: String + } + deriving (Eq, Generic, Read, Show) instance FromJWT User + instance ToJWT User + instance FromJSON User + instance ToJSON User instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary instance Postable User where - postPayload user request = return $ request - { HCli.requestBody = HCli.RequestBodyLBS $ encode user - , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request - } - + postPayload user request = + return $ + request + { HCli.requestBody = HCli.RequestBodyLBS $ encode user + , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request + } -- }}}