servant-auth-server 0.4.9.0 → 0.4.9.1
raw patch · 16 files changed
+965/−805 lines, 16 filesdep +data-defaultdep −data-default-classdep ~QuickCheckdep ~basedep ~bytestringsetup-changednew-uploader
Dependencies added: data-default
Dependencies removed: data-default-class
Dependency ranges changed: QuickCheck, base, bytestring
Files
- CHANGELOG.md +3/−1
- Setup.hs +1/−0
- servant-auth-server.cabal +6/−6
- src/Servant/Auth/Server.hs +106/−100
- src/Servant/Auth/Server/Internal.hs +37/−28
- src/Servant/Auth/Server/Internal/AddSetCookie.hs +54/−41
- src/Servant/Auth/Server/Internal/BasicAuth.hs +11/−12
- src/Servant/Auth/Server/Internal/Class.hs +28/−19
- src/Servant/Auth/Server/Internal/ConfigTypes.hs +72/−66
- src/Servant/Auth/Server/Internal/Cookie.hs +87/−80
- src/Servant/Auth/Server/Internal/FormLogin.hs +0/−2
- src/Servant/Auth/Server/Internal/JWT.hs +25/−21
- src/Servant/Auth/Server/Internal/ThrowAll.hs +22/−18
- src/Servant/Auth/Server/Internal/Types.hs +25/−26
- src/Servant/Auth/Server/SetCookieOrphan.hs +3/−2
- test/Servant/Auth/ServerSpec.hs +485/−383
CHANGELOG.md view
@@ -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.
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
servant-auth-server.cabal view
@@ -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
src/Servant/Auth/Server.hs view
@@ -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
src/Servant/Auth/Server/Internal.hs view
@@ -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
src/Servant/Auth/Server/Internal/AddSetCookie.hs view
@@ -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
src/Servant/Auth/Server/Internal/BasicAuth.hs view
@@ -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
src/Servant/Auth/Server/Internal/Class.hs view
@@ -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
src/Servant/Auth/Server/Internal/ConfigTypes.hs view
@@ -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 <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document> -- 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+ -- }}}
src/Servant/Auth/Server/Internal/Cookie.hs view
@@ -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)
src/Servant/Auth/Server/Internal/FormLogin.hs view
@@ -1,3 +1,1 @@ module Servant.Auth.Server.Internal.FormLogin where--
src/Servant/Auth/Server/Internal/JWT.hs view
@@ -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
src/Servant/Auth/Server/Internal/ThrowAll.hs view
@@ -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)
src/Servant/Auth/Server/Internal/Types.hs view
@@ -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
src/Servant/Auth/Server/SetCookieOrphan.hs view
@@ -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
test/Servant/Auth/ServerSpec.hs view
@@ -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+ } -- }}}