servant-auth-server 0.3.2.0 → 0.4.0.0

raw patch · 10 files changed

+633/−407 lines, 10 filesdep +semigroupsdep +servantdep ~basedep ~cookiedep ~http-api-datanew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: semigroups, servant

Dependency ranges changed: base, cookie, http-api-data, jose, monad-time, servant-server

API changes (from Hackage documentation)

Files

• README.lhs +284/−0
• executables/README.lhs +0/−270
• servant-auth-server.cabal +15/−11
• src/Servant/Auth/Server.hs +5/−1
• src/Servant/Auth/Server/Internal.hs +2/−2
• src/Servant/Auth/Server/Internal/ConfigTypes.hs +50/−25
• src/Servant/Auth/Server/Internal/Cookie.hs +90/−35
• src/Servant/Auth/Server/Internal/JWT.hs +5/−3
• src/Servant/Auth/Server/Internal/Types.hs +13/−6
• test/Servant/Auth/ServerSpec.hs +169/−54

@@ -0,0 +1,284 @@+# servant-auth++[![Build Status](https://travis-ci.org/haskell-servant/servant-auth.svg?branch=master)](https://travis-ci.org/haskell-servant/servant-auth)++This package provides safe and easy-to-use authentication options for+`servant`. The same API can be protected via login and cookies, or API tokens,+without much extra work.+++## How it works++First some imports:++~~~ haskell+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+import Control.Concurrent (forkIO)+import Control.Monad (forever)+import Control.Monad.Trans (liftIO)+import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generic)+import Network.Wai.Handler.Warp (run)+import System.Environment (getArgs)+import Servant+import Servant.Auth.Server+import Servant.Auth.Server.SetCookieOrphan ()+~~~++`servant-auth` library introduces a combinator `Auth`:++~~~ haskell+data Auth (auths :: [*]) val+~~~++What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by+*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type+`AuthResult Something`, where :++~~~ haskell+data AuthResult val+  = BadPassword+  | NoSuchUser+  | Authenticated val+  | Indefinite+~~~++Your handlers will get a value of type `AuthResult Something`, and can decide+what to do with it.++~~~ haskell++data User = User { name :: String, email :: String }+   deriving (Eq, Show, Read, Generic)++instance ToJSON User+instance ToJWT User+instance FromJSON User+instance FromJWT User++data Login = Login { username :: String, password :: String }+   deriving (Eq, Show, Read, Generic)++instance ToJSON Login+instance FromJSON Login++type Protected+   = "name" :> Get '[JSON] String+ :<|> "email" :> Get '[JSON] String+++-- | 'Protected' will be protected by 'auths', which we still have to specify.+protected :: Servant.Auth.Server.AuthResult User -> Server Protected+-- If we get an "Authenticated v", we can trust the information in v, since+-- it was signed by a key we trust.+protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user)+-- Otherwise, we return a 401.+protected _ = throwAll err401++type Unprotected =+ "login"+     :> ReqBody '[JSON] Login+     :> PostNoContent '[JSON] (Headers '[ Header "Set-Cookie" SetCookie+                                        , Header "Set-Cookie" SetCookie]+                                       NoContent)+  :<|> Raw++unprotected :: CookieSettings -> JWTSettings -> Server Unprotected+unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static"++type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected++server :: CookieSettings -> JWTSettings -> Server (API auths)+server cs jwts = protected :<|> unprotected cs jwts++~~~++The code is common to all authentications. In order to pick one or more specific+authentication methods, all we need to do is provide the expect configuration+parameters.++## API tokens++The following example illustrates how to protect an API with tokens.+++~~~ haskell+-- In main, we fork the server, and allow new tokens to be created in the+-- command line for the specified user name and email.+mainWithJWT :: IO ()+mainWithJWT = do+  -- We generate the key for signing tokens. This would generally be persisted,+  -- and kept safely+  myKey <- generateKey+  -- Adding some configurations. All authentications require CookieSettings to+  -- be in the context.+  let jwtCfg = defaultJWTSettings myKey+      cfg = defaultCookieSettings :. jwtCfg :. EmptyContext+      --- Here we actually make concrete+      api = Proxy :: Proxy (API '[JWT])+  _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)++  putStrLn "Started server on localhost:7249"+  putStrLn "Enter name and email separated by a space for a new token"++  forever $ do+     xs <- words <$> getLine+     case xs of+       [name', email'] -> do+         etoken <- makeJWT (User name' email') jwtCfg Nothing+         case etoken of+           Left e -> putStrLn $ "Error generating token:t" ++ show e+           Right v -> putStrLn $ "New token:\t" ++ show v+       _ -> putStrLn "Expecting a name and email separated by spaces"++~~~++And indeed:++~~~ bash++./readme JWT++    Started server on localhost:7249+    Enter name and email separated by a space for a new token+    alice alice@gmail.com+    New token:	"eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE"++curl localhost:7249/name -v++    * Hostname was NOT found in DNS cache+    *   Trying 127.0.0.1...+    * Connected to localhost (127.0.0.1) port 7249 (#0)+    > GET /name HTTP/1.1+    > User-Agent: curl/7.35.0+    > Host: localhost:7249+    > Accept: */*+    >+    < HTTP/1.1 401 Unauthorized+    < Transfer-Encoding: chunked+    < Date: Wed, 07 Sep 2016 20:17:17 GMT+    * Server Warp/3.2.7 is not blacklisted+    < Server: Warp/3.2.7+    <+    * Connection #0 to host localhost left intact++curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \+  localhost:7249/name -v++    * Hostname was NOT found in DNS cache+    *   Trying 127.0.0.1...+    * Connected to localhost (127.0.0.1) port 7249 (#0)+    > GET /name HTTP/1.1+    > User-Agent: curl/7.35.0+    > Host: localhost:7249+    > Accept: */*+    > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE+    >+    < HTTP/1.1 200 OK+    < Transfer-Encoding: chunked+    < Date: Wed, 07 Sep 2016 20:16:11 GMT+    * Server Warp/3.2.7 is not blacklisted+    < Server: Warp/3.2.7+    < Content-Type: application/json+    < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure+    <  Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure+    <+    * Connection #0 to host localhost left intact+    "alice"%+++~~~++## Cookies++What if, in addition to API tokens, we want to expose our API to browsers? All+we need to do is say so!++~~~ haskell+mainWithCookies :: IO ()+mainWithCookies = do+  -- We *also* need a key to sign the cookies+  myKey <- generateKey+  -- Adding some configurations. 'Cookie' requires, in addition to+  -- CookieSettings, JWTSettings (for signing), so everything is just as before+  let jwtCfg = defaultJWTSettings myKey+      cfg = defaultCookieSettings :. jwtCfg :. EmptyContext+      --- Here is the actual change+      api = Proxy :: Proxy (API '[Cookie])+  run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)+++-- Here is the login handler+checkCreds :: CookieSettings+           -> JWTSettings+           -> Login+           -> Handler (Headers '[ Header "Set-Cookie" SetCookie+                                , Header "Set-Cookie" SetCookie]+                               NoContent)+checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do+   -- Usually you would ask a database for the user info. This is just a+   -- regular servant handler, so you can follow your normal database access+   -- patterns (including using 'enter').+   let usr = User "Ali Baba" "ali@email.com"+   mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr+   case mApplyCookies of+     Nothing           -> throwError err401+     Just applyCookies -> return $ applyCookies NoContent+checkCreds _ _ _ = throwError err401+~~~++### XSRF and the frontend++XSRF protection works by requiring that there be a header of the same value as+a distinguished cookie that is set by the server on each request. What the+cookie and header name are can be configured (see `xsrfCookieName` and+`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and+"X-XSRF-TOKEN". This means that, if your client is a browser and your are using+cookies, Javascript on the client must set the header of each request by+reading the cookie. For jQuery, and with the default values, that might be:++~~~ javascript++var token = (function() {+  r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)'))+  if (r) return r[1];+)();+++$.ajaxPrefilter(function(opts, origOpts, xhr) {+  xhr.setRequestHeader('X-XSRF-TOKEN', token);+  }++~~~++I *believe* nothing at all needs to be done if you're using Angular's `$http`+directive, but I haven't tested this.++XSRF protection can be disabled just for `GET` requests by setting+`xsrfExcludeGet = False`. You might want this if you're relying on the browser+to navigate between pages that require cookie authentication.++XSRF protection can be completely disabled by setting `cookieXsrfSetting =+Nothing` in `CookieSettings`. This is not recommended! If your cookie+authenticated web application runs any javascript, it's recommended to send the+XSRF header. However, if your web application runs no javascript, disabling+XSRF entirely may be required.++# Note on this README++This README is a literate haskell file. Here is 'main', allowing you to pick+between the examples above.++~~~ haskell++main :: IO ()+main = do+  args <- getArgs+  let usage = "Usage: readme (JWT|Cookie)"+  case args of+    ["JWT"] -> mainWithJWT+    ["Cookie"] -> mainWithCookies+    e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage++~~~

@@ -1,270 +0,0 @@-# servant-auth--[![Build Status](https://travis-ci.org/haskell-servant/servant-auth.svg?branch=master)](https://travis-ci.org/haskell-servant/servant-auth)--This package provides safe and easy-to-use authentication options for-`servant`. The same API can be protected via login and cookies, or API tokens,-without much extra work.---## How it works--This library introduces a combinator `Auth`:--~~~ {.haskell ignore}-Auth (auths :: [*]) val-~~~--What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by-*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type-`AuthResult Something`, where :--~~~ {.haskell ignore}-data AuthResult val-  = BadPassword-  | NoSuchUser-  | Authenticated val-  | Indefinite-~~~--Your handlers will get a value of type `AuthResult Something`, and can decide-what to do with it.--~~~ {.haskell}-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}-import Control.Concurrent (forkIO)-import Control.Monad (forever)-import Control.Monad.Trans (liftIO)-import Data.Aeson (FromJSON, ToJSON)-import GHC.Generics (Generic)-import Network.Wai.Handler.Warp (run)-import System.Environment (getArgs)-import Servant-import Servant.Auth.Server-import Servant.Auth.Server.SetCookieOrphan ()--data User = User { name :: String, email :: String }-   deriving (Eq, Show, Read, Generic)--instance ToJSON User-instance ToJWT User-instance FromJSON User-instance FromJWT User--data Login = Login { username :: String, password :: String }-   deriving (Eq, Show, Read, Generic)--instance ToJSON Login-instance FromJSON Login--type Protected-   = "name" :> Get '[JSON] String- :<|> "email" :> Get '[JSON] String----- | 'Protected' will be protected by 'auths', which we still have to specify.-protected :: AuthResult User -> Server Protected--- If we get an "Authenticated v", we can trust the information in v, since--- it was signed by a key we trust.-protected (Authenticated user) = return (name user) :<|> return (email user)--- Otherwise, we return a 401.-protected _ = throwAll err401--type Unprotected =- "login"-     :> ReqBody '[JSON] Login-     :> PostNoContent '[JSON] (Headers '[ Header "Set-Cookie" SetCookie-                                        , Header "Set-Cookie" SetCookie]-                                       NoContent)-  :<|> Raw--unprotected :: CookieSettings -> JWTSettings -> Server Unprotected-unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static"--type API auths = (Auth auths User :> Protected) :<|> Unprotected--server :: CookieSettings -> JWTSettings -> Server (API auths)-server cs jwts = protected :<|> unprotected cs jwts--~~~--The code is common to all authentications. In order to pick one or more specific-authentication methods, all we need to do is provide the expect configuration-parameters.--## API tokens--The following example illustrates how to protect an API with tokens.---~~~ {.haskell}--- In main, we fork the server, and allow new tokens to be created in the--- command line for the specified user name and email.-mainWithJWT :: IO ()-mainWithJWT = do-  -- We generate the key for signing tokens. This would generally be persisted,-  -- and kept safely-  myKey <- generateKey-  -- Adding some configurations. All authentications require CookieSettings to-  -- be in the context.-  let jwtCfg = defaultJWTSettings myKey-      cfg = defaultCookieSettings :. jwtCfg :. EmptyContext-      --- Here we actually make concrete-      api = Proxy :: Proxy (API '[JWT])-  _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)--  putStrLn "Started server on localhost:7249"-  putStrLn "Enter name and email separated by a space for a new token"--  forever $ do-     xs <- words <$> getLine-     case xs of-       [name', email'] -> do-         etoken <- makeJWT (User name' email') jwtCfg Nothing-         case etoken of-           Left e -> putStrLn $ "Error generating token:t" ++ show e-           Right v -> putStrLn $ "New token:\t" ++ show v-       _ -> putStrLn "Expecting a name and email separated by spaces"--~~~--And indeed:--~~~ {.bash}--./readme JWT--    Started server on localhost:7249-    Enter name and email separated by a space for a new token-    alice alice@gmail.com-    New token:	"eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE"--curl localhost:7249/name -v--    * Hostname was NOT found in DNS cache-    *   Trying 127.0.0.1...-    * Connected to localhost (127.0.0.1) port 7249 (#0)-    > GET /name HTTP/1.1-    > User-Agent: curl/7.35.0-    > Host: localhost:7249-    > Accept: */*-    >-    < HTTP/1.1 401 Unauthorized-    < Transfer-Encoding: chunked-    < Date: Wed, 07 Sep 2016 20:17:17 GMT-    * Server Warp/3.2.7 is not blacklisted-    < Server: Warp/3.2.7-    <-    * Connection #0 to host localhost left intact--curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \-  localhost:7249/name -v--    * Hostname was NOT found in DNS cache-    *   Trying 127.0.0.1...-    * Connected to localhost (127.0.0.1) port 7249 (#0)-    > GET /name HTTP/1.1-    > User-Agent: curl/7.35.0-    > Host: localhost:7249-    > Accept: */*-    > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE-    >-    < HTTP/1.1 200 OK-    < Transfer-Encoding: chunked-    < Date: Wed, 07 Sep 2016 20:16:11 GMT-    * Server Warp/3.2.7 is not blacklisted-    < Server: Warp/3.2.7-    < Content-Type: application/json-    < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure-    <  Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure-    <-    * Connection #0 to host localhost left intact-    "alice"%---~~~--## Cookies--What if, in addition to API tokens, we want to expose our API to browsers? All-we need to do is say so!--~~~ {.haskell}-mainWithCookies :: IO ()-mainWithCookies = do-  -- We *also* need a key to sign the cookies-  myKey <- generateKey-  -- Adding some configurations. 'Cookie' requires, in addition to-  -- CookieSettings, JWTSettings (for signing), so everything is just as before-  let jwtCfg = defaultJWTSettings myKey-      cfg = defaultCookieSettings :. jwtCfg :. EmptyContext-      --- Here is the actual change-      api = Proxy :: Proxy (API '[Cookie])-  run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)----- Here is the login handler-checkCreds :: CookieSettings-           -> JWTSettings-           -> Login-           -> Handler (Headers '[ Header "Set-Cookie" SetCookie-                                , Header "Set-Cookie" SetCookie]-                               NoContent)-checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do-   -- Usually you would ask a database for the user info. This is just a-   -- regular servant handler, so you can follow your normal database access-   -- patterns (including using 'enter').-   let usr = User "Ali Baba" "ali@email.com"-   mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr-   case mApplyCookies of-     Nothing           -> throwError err401-     Just applyCookies -> return $ applyCookies NoContent-checkCreds _ _ _ = throwError err401-~~~--### CSRF and the frontend--CSRF protection works by requiring that there be a header of the same value as-a distinguished cookie that is set by the server on each request. What the-cookie and header name are can be configured (see `xsrfCookieName` and-`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and-"X-XSRF-TOKEN". This means that, if your client is a browser and your are using-cookies, Javascript on the client must set the header of each request by-reading the cookie. For jQuery, and with the default values, that might be:--~~~ { .javascript }--var token = (function() {-  r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)'))-  if (r) return r[1];-)();---$.ajaxPrefilter(function(opts, origOpts, xhr) {-  xhr.setRequestHeader('X-XSRF-TOKEN', token);-  }--~~~---I *believe* nothing at all needs to be done if you're using Angular's `$http`-directive, but I haven't tested this.--# Note on this README--This README is a literate haskell file. Here is 'main', allowing you to pick-between the examples above.--~~~ { .haskell }--main :: IO ()-main = do-  args <- getArgs-  let usage = "Usage: readme (JWT|Cookie)"-  case args of-    ["JWT"] -> mainWithJWT-    ["Cookie"] -> mainWithCookies-    e -> error $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage--~~~

@@ -1,5 +1,5 @@ name:           servant-auth-server-version:        0.3.2.0+version:        0.4.0.0 synopsis:       servant-server/servant-auth compatibility description:    This package provides the required instances for using the @Auth@ combinator                 in your 'servant' server.@@ -15,7 +15,7 @@ copyright:      (c) Julian K. Arni license:        BSD3 license-file:   LICENSE-tested-with:    GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2+tested-with:    GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 build-type:     Simple cabal-version:  >= 1.10 @@ -29,30 +29,34 @@   default-extensions: AutoDeriveTypeable 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.8  && < 4.11+      base                    >= 4.8  && < 4.12     , aeson                   >= 0.11 && < 2     , base64-bytestring       >= 1    && < 2     , blaze-builder           >= 0.4  && < 0.5     , bytestring              >= 0.10 && < 0.11     , bytestring-conversion   >= 0.3  && < 0.4     , case-insensitive        >= 1.2  && < 1.3-    , cookie                  >= 0.4  && < 0.4.4+    , cookie                  >= 0.4  && < 0.5     , crypto-api              >= 0.13 && < 0.14     , data-default-class      >= 0.0  && < 0.2     , entropy                 >= 0.3  && < 0.5-    , http-api-data           >= 0.3  && < 0.3.8+    , http-api-data           >= 0.3.7 && < 0.4     , http-types              >= 0.9  && < 0.13-    , jose                    >= 0.6  && < 0.7+    , jose                    >= 0.6  && < 0.8     , lens                    >= 4    && < 5-    , monad-time              >= 0.2  && < 0.3+    , monad-time              >= 0.2  && < 0.4     , mtl                     >= 2.2  && < 2.3+    , servant                 >= 0.9.1  && < 0.15     , servant-auth            == 0.3.*-    , servant-server          >= 0.9.1  && < 0.14+    , servant-server          >= 0.9.1  && < 0.15     , tagged                  >= 0.7.3 && < 0.9     , text                    >= 1    && < 2     , time                    >= 1.5  && < 1.9     , unordered-containers    >= 0.2  && < 0.3     , wai                     >= 3.2  && < 3.3+  if !impl(ghc >= 8.0)+    build-depends:+      semigroups >= 0.18.1 && <0.19   exposed-modules:       Servant.Auth.Server       Servant.Auth.Server.Internal@@ -68,10 +72,9 @@       Servant.Auth.Server.SetCookieOrphan   default-language: Haskell2010 -executable readme+test-suite readme+  type: exitcode-stdio-1.0   main-is: README.lhs-  hs-source-dirs:-      executables   default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators   ghc-options: -Wall -pgmL markdown-unlit   build-tool-depends: markdown-unlit:markdown-unlit@@ -111,6 +114,7 @@     , http-types     , wai     , servant-server+    , transformers    -- test dependencies   build-depends:

@@ -67,18 +67,22 @@    -- ** Settings   , CookieSettings(..)+  , XsrfCookieSettings(..)   , defaultCookieSettings+  , defaultXsrfCookieSettings   , makeSessionCookie   , makeSessionCookieBS+  , makeXsrfCookie   , makeCsrfCookie   , makeCookie   , makeCookieBS   , acceptLogin+  , clearSession     -- ** Related types   , IsSecure(..)-+  , SameSite(..)   , AreAuths    ----------------------------------------------------------------------------

@@ -53,8 +53,8 @@        makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))       makeCookies authResult = do-        csrf <- makeCsrfCookie cookieSettings-        fmap (Just csrf `SetCookieCons`) $+        xsrf <- makeXsrfCookie cookieSettings+        fmap (Just xsrf `SetCookieCons`) $           case authResult of             (Authenticated v) -> do               ejwt <- makeSessionCookie cookieSettings jwtSettings v

@@ -1,4 +1,7 @@-module Servant.Auth.Server.Internal.ConfigTypes where+module Servant.Auth.Server.Internal.ConfigTypes+  ( module Servant.Auth.Server.Internal.ConfigTypes+  , Servant.API.IsSecure(..)+  ) where  import           Crypto.JOSE        as Jose import           Crypto.JWT         as Jose@@ -6,13 +9,11 @@ import           Data.Default.Class import           Data.Time import           GHC.Generics       (Generic)+import           Servant.API        (IsSecure(..))  data IsMatch = Matches | DoesNotMatch   deriving (Eq, Show, Read, Generic, Ord) -data IsSecure = Secure | NotSecure-  deriving (Eq, Show, Read, Generic, Ord)- data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect   deriving (Eq, Show, Read, Generic, Ord) @@ -26,7 +27,13 @@  -- | @JWTSettings@ are used to generate cookies, and to verify JWTs. data JWTSettings = JWTSettings-  { key             :: Jose.JWK+  {+  -- | Key used to sign JWT.+    signingKey      :: Jose.JWK+  -- | Algorithm used to sign JWT.+  , jwtAlg          :: Maybe Jose.Alg+  -- | Keys used to validate JWT.+  , validationKeys  :: Jose.JWKSet   -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the   -- intended recipient of the JWT.   , audienceMatches :: Jose.StringOrURI -> IsMatch@@ -34,7 +41,11 @@  -- | A @JWTSettings@ where the audience always matches. defaultJWTSettings :: Jose.JWK -> JWTSettings-defaultJWTSettings k = JWTSettings { key = k, audienceMatches = const Matches }+defaultJWTSettings k = JWTSettings+   { signingKey = k+   , jwtAlg = Nothing+   , validationKeys = Jose.JWKSet [k]+   , audienceMatches = const Matches }  -- | The policies to use when generating cookies. --@@ -48,25 +59,19 @@   {   -- | 'Secure' means browsers will only send cookies over HTTPS. Default:   -- @Secure@.-    cookieIsSecure    :: IsSecure+    cookieIsSecure    :: !IsSecure   -- | How long from now until the cookie expires. Default: @Nothing@.-  , cookieMaxAge      :: Maybe DiffTime+  , cookieMaxAge      :: !(Maybe DiffTime)   -- | At what time the cookie expires. Default: @Nothing@.-  , cookieExpires     :: Maybe UTCTime+  , cookieExpires     :: !(Maybe UTCTime)   -- | The URL path and sub-paths for which this cookie is used. Default @Just "/"@.-  , cookiePath        :: Maybe BS.ByteString+  , cookiePath        :: !(Maybe BS.ByteString)   -- | 'SameSite' settings. Default: @SameSiteLax@.-  , cookieSameSite    :: SameSite+  , cookieSameSite    :: !SameSite   -- | What name to use for the cookie used for the session.-  , sessionCookieName :: BS.ByteString-  -- | What name to use for the cookie used for CSRF protection.-  , xsrfCookieName    :: BS.ByteString-  -- | What path to use for the cookie used for CSRF protection. Default @Just "/"@.-  , xsrfCookiePath    :: Maybe BS.ByteString-  -- | What name to use for the header used for CSRF protection.-  , xsrfHeaderName    :: BS.ByteString-  -- | Exclude GET request method from CSRF protection.-  , xsrfExcludeGet    :: Bool+  , sessionCookieName :: !BS.ByteString+  -- | The optional settings to use for XSRF protection. Default @Just def@.+  , cookieXsrfSetting :: !(Maybe XsrfCookieSettings)   } deriving (Eq, Show, Generic)  instance Default CookieSettings where@@ -80,13 +85,33 @@     , cookiePath        = Just "/"     , cookieSameSite    = SameSiteLax     , sessionCookieName = "JWT-Cookie"-    , xsrfCookieName    = "XSRF-TOKEN"-    , xsrfCookiePath    = Just "/"-    , xsrfHeaderName    = "X-XSRF-TOKEN"-    , xsrfExcludeGet    = False+    , cookieXsrfSetting = Just def     } +-- | The policies to use when generating and verifying XSRF cookies+data XsrfCookieSettings = XsrfCookieSettings+  {+  -- | What name to use for the cookie used for XSRF protection.+    xsrfCookieName :: !BS.ByteString+  -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@.+  , xsrfCookiePath :: !(Maybe BS.ByteString)+  -- | What name to use for the header used for XSRF protection.+  , xsrfHeaderName :: !BS.ByteString+  -- | Exclude GET request method from XSRF protection.+  , xsrfExcludeGet :: !Bool+  } deriving (Eq, Show, Generic) +instance Default XsrfCookieSettings where+  def = defaultXsrfCookieSettings++defaultXsrfCookieSettings :: XsrfCookieSettings+defaultXsrfCookieSettings = XsrfCookieSettings+  { xsrfCookieName = "XSRF-TOKEN"+  , xsrfCookiePath = Just "/"+  , xsrfHeaderName = "X-XSRF-TOKEN"+  , xsrfExcludeGet = False+  }+ ------------------------------------------------------------------------------ -- Internal {{{ @@ -94,6 +119,6 @@ jwtSettingsToJwtValidationSettings s   = defaultJWTValidationSettings (toBool <$> audienceMatches s)   where-    toBool Matches = True+    toBool Matches      = True     toBool DoesNotMatch = False -- }}}

@@ -7,11 +7,14 @@ import qualified Crypto.JWT               as Jose import           Crypto.Util              (constTimeEq) import qualified Data.ByteString          as BS+import qualified Data.ByteString.Char8    as BSC import qualified Data.ByteString.Base64   as BS64 import qualified Data.ByteString.Lazy     as BSL import           Data.CaseInsensitive     (mk)+import           Data.Maybe               (fromMaybe, isJust) import           Network.HTTP.Types       (methodGet)-import           Network.Wai              (requestHeaders, requestMethod)+import           Network.HTTP.Types.Header(hCookie)+import           Network.Wai              (Request, requestHeaders, requestMethod) import           Servant                  (AddHeader, addHeader) import           System.Entropy           (getEntropy) import           Web.Cookie@@ -26,18 +29,18 @@ cookieAuthCheck ccfg jwtCfg = do   req <- ask   jwtCookie <- maybe mempty return $ do-    cookies' <- lookup "Cookie" $ requestHeaders req+    cookies' <- lookup hCookie $ requestHeaders req     let cookies = parseCookies cookies'-    xsrfCookie <- lookup (xsrfCookieName ccfg) cookies-    when (((requestMethod req) /= methodGet) || not (xsrfExcludeGet ccfg)) $ do-      xsrfHeader <- lookup (mk $ xsrfHeaderName ccfg) $ requestHeaders req-      guard $ xsrfCookie `constTimeEq` xsrfHeader+    -- Apply the XSRF check if enabled.+    guard $ fromMaybe True $ do+      xsrfCookieCfg <- xsrfCheckRequired ccfg req+      return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies     -- session cookie *must* be HttpOnly and Secure     lookup (sessionCookieName ccfg) cookies   verifiedJWT <- liftIO $ runExceptT $ do     unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict jwtCookie     Jose.verifyClaims (jwtSettingsToJwtValidationSettings jwtCfg)-                      (key jwtCfg)+                      (validationKeys jwtCfg)                       unverifiedJWT   case verifiedJWT of     Left (_ :: Jose.JWTError) -> mzero@@ -45,41 +48,80 @@       Left _ -> mzero       Right v' -> return v' --- | Makes a cookie to be used for CSRF.+xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings+xsrfCheckRequired cookieSettings req = do+    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+  xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies+  xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req+  return $ xsrfCookie `constTimeEq` xsrfHeader++-- | Makes a cookie to be used for XSRF.+makeXsrfCookie :: CookieSettings -> IO SetCookie+makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of+  Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings+  Nothing                 -> return $ noXsrfTokenCookie cookieSettings+  where+    makeRealCookie xsrfCookieSettings = do+      xsrfValue <- BS64.encode <$> getEntropy 32+      return+        $ applyXsrfCookieSettings xsrfCookieSettings+        $ applyCookieSettings cookieSettings+        $ def{ setCookieValue = xsrfValue }+++-- | Alias for 'makeXsrfCookie'. makeCsrfCookie :: CookieSettings -> IO SetCookie-makeCsrfCookie cookieSettings = do-  csrfValue <- BS64.encode <$> getEntropy 32-  return $ def-    { setCookieName = xsrfCookieName cookieSettings-    , setCookieValue = csrfValue-    , setCookieMaxAge = cookieMaxAge cookieSettings-    , setCookieExpires = cookieExpires cookieSettings-    , setCookiePath = xsrfCookiePath cookieSettings-    , setCookieSecure = case cookieIsSecure cookieSettings of-        Secure -> True-        NotSecure -> False-    }+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 Nothing+  ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)   case ejwt of     Left _ -> return Nothing-    Right jwt -> return $ Just $ def-      { setCookieName = sessionCookieName cookieSettings-      , setCookieValue = BSL.toStrict jwt-      , setCookieHttpOnly = True-      , setCookieMaxAge = cookieMaxAge cookieSettings-      , setCookieExpires = cookieExpires cookieSettings-      , setCookiePath = cookiePath cookieSettings-      , setCookieSecure = case cookieIsSecure cookieSettings of-          Secure -> True-          NotSecure -> False-      }+    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 -> SetCookie -> SetCookie+applyCookieSettings cookieSettings setCookie = setCookie+  { setCookieMaxAge = cookieMaxAge cookieSettings+  , setCookieExpires = cookieExpires cookieSettings+  , setCookiePath = cookiePath cookieSettings+  , setCookieSecure = case cookieIsSecure cookieSettings of+      Secure -> True+      NotSecure -> False+  }++applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie+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+  }+ -- | For a JWT-serializable session, returns a function that decorates a--- provided response object with CSRF and session cookies. This should be used+-- provided response object with XSRF and session cookies. This should be used -- when a user successfully authenticates with credentials. acceptLogin :: ( ToJWT session                , AddHeader "Set-Cookie" SetCookie response withOneCookie@@ -93,8 +135,21 @@   case mSessionCookie of     Nothing            -> pure Nothing     Just sessionCookie -> do-      csrfCookie <- makeCsrfCookie cookieSettings-      return $ Just $ addHeader sessionCookie . addHeader csrfCookie+      xsrfCookie <- makeXsrfCookie cookieSettings+      return $ Just $ addHeader sessionCookie . addHeader xsrfCookie++-- | Adds headers to a response that clears all session cookies.+clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie+                , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )+             => CookieSettings+             -> response+             -> withTwoCookies+clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie+  where+    clearedSessionCookie = applySessionCookieSettings cookieSettings $ applyCookieSettings cookieSettings def+    clearedXsrfCookie = case cookieXsrfSetting cookieSettings of+        Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettings def+        Nothing                 -> noXsrfTokenCookie cookieSettings  makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie)  <$> makeSessionCookie a b c

@@ -11,6 +11,7 @@ import qualified Data.ByteString      as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict  as HM+import           Data.Maybe           (fromMaybe) import qualified Data.Text            as T import           Data.Time            (UTCTime) import           Network.Wai          (requestHeaders)@@ -56,7 +57,7 @@   verifiedJWT <- liftIO $ runExceptT $ do     unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict token     Jose.verifyClaims (jwtSettingsToJwtValidationSettings config)-                      (key config)+                      (validationKeys config)                       unverifiedJWT   case verifiedJWT of     Left (_ :: Jose.JWTError) -> mzero@@ -72,8 +73,9 @@ makeJWT :: ToJWT a   => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString) makeJWT v cfg expiry = runExceptT $ do-  alg <- Jose.bestJWSAlg $ key cfg-  ejwt <- Jose.signClaims (key cfg)+  bestAlg <- Jose.bestJWSAlg $ signingKey cfg+  let alg = fromMaybe bestAlg $ jwtAlg cfg+  ejwt <- Jose.signClaims (signingKey cfg)                           (Jose.newJWSHeader ((), alg))                           (addExp $ encodeJWT v) 

@@ -3,7 +3,8 @@ import Control.Applicative import Control.Monad.Reader import Control.Monad.Time-import Data.Monoid+import Data.Monoid          (Monoid (..))+import Data.Semigroup       (Semigroup (..)) import Data.Time            (getCurrentTime) import GHC.Generics         (Generic) import Network.Wai          (Request)@@ -21,10 +22,13 @@   | Indefinite   deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable) +instance Semigroup (AuthResult val) where+  Indefinite <> y = y+  x          <> _ = x+ instance Monoid (AuthResult val) where   mempty = Indefinite-  Indefinite `mappend` x = x-  x `mappend` _ = x+  mappend = (<>)  instance Applicative AuthResult where   pure = return@@ -54,12 +58,15 @@   { runAuthCheck :: Request -> IO (AuthResult val) }   deriving (Generic, Functor) -instance Monoid (AuthCheck val) where-  mempty = AuthCheck $ const $ return mempty-  AuthCheck f `mappend` AuthCheck g = AuthCheck $ \x -> do+instance Semigroup (AuthCheck val) where+  AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do     fx <- f x     gx <- g x     return $ fx <> gx++instance Monoid (AuthCheck val) where+  mempty = AuthCheck $ const $ return mempty+  mappend = (<>)  instance Applicative AuthCheck where   pure = return

@@ -3,6 +3,7 @@  import           Control.Lens import           Control.Monad.Except                (runExceptT)+import           Control.Monad.IO.Class              (liftIO) import           Crypto.JOSE                         (Alg (HS256, None), Error,                                                       JWK, JWSHeader,                                                       KeyMaterialGenParam (OctGenParam),@@ -16,7 +17,7 @@                                                       emptyClaimsSet,                                                       unregisteredClaims) import           Data.Aeson                          (FromJSON, ToJSON, Value,-                                                      toJSON)+                                                      toJSON, encode) import           Data.Aeson.Lens                     (_JSON) import qualified Data.ByteString                     as BS import qualified Data.ByteString.Lazy                as BSL@@ -34,12 +35,13 @@ import           Network.Wai.Handler.Warp            (testWithApplication) import           Network.Wreq                        (Options, auth, basicAuth,                                                       cookieExpiryTime, cookies,-                                                      defaults, get, getWith,+                                                      defaults, get, getWith, postWith,                                                       header, oauth2Bearer,                                                       responseBody,                                                       responseCookieJar,                                                       responseHeader,                                                       responseStatus)+import           Network.Wreq.Types                  (Postable(..)) import           Servant                             hiding (BasicAuth,                                                       IsSecure (..), header) import           Servant.Auth.Server@@ -47,12 +49,7 @@ import           System.IO.Unsafe                    (unsafePerformIO) import           Test.Hspec import           Test.QuickCheck--#if MIN_VERSION_http_client(0,5,0) import qualified Network.HTTP.Client as HCli-#else-import Network.HTTP.Client (HttpException (StatusCodeException))-#endif   @@ -115,40 +112,40 @@     it "sets cookies that it itself accepts" $ \port -> property $ \user -> do       jwt <- createJWT theKey (newJWSHeader ((), HS256))         (claims $ toJSON user)-      opts' <- addJwtToCookie jwt-      let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"])-                           (xsrfCookieName cookieCfg <> "=blah")+      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 == xsrfCookieName cookieCfg)+          Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)                      $ destroyCookieJar cookieJar           opts2 = defaults             & cookies .~ Just cookieJar-            & header (mk (xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]+            & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]       resp2 <- getWith opts2 (url port)       resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)      it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do       jwt <- createJWT theKey (newJWSHeader ((), HS256))         (claims $ toJSON user)-      opts' <- addJwtToCookie jwt-      let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"])-                           (xsrfCookieName cookieCfg <> "=blah")+      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 == xsrfCookieName cookieCfg)+          Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)                      $ destroyCookieJar cookieJar       xxsrf ^. cookieExpiryTime `shouldBe` future      it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do       jwt <- createJWT theKey (newJWSHeader ((), HS256))         (claims $ toJSON user)-      opts' <- addJwtToCookie jwt-      let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"])-                           (xsrfCookieName cookieCfg <> "=blah")+      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 == "JWT-Cookie")+          Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)                      $ destroyCookieJar cookieJar       cookie_http_only token `shouldBe` True @@ -161,42 +158,120 @@ cookieAuthSpec :: Spec cookieAuthSpec   = describe "The Auth combinator" $ do-      around (testWithApplication . return $ app cookieOnlyApi) $ do+      describe "With XSRF check" $+       around (testWithApplication . return $ app cookieOnlyApi) $ do -        it "fails if CSRF header and cookie don't match" $ \port -> property+        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 jwt-          let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"])-                               (xsrfCookieName cookieCfg <> "=blerg")+          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 "fails if there is no CSRF header and cookie" $ \port -> property+        it "fails with no XSRF header or cookie" $ \port -> property                                                          $ \(user :: User) -> do           jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)-          opts <- addJwtToCookie jwt+          opts <- addJwtToCookie cookieCfg jwt           getWith opts (url port) `shouldHTTPErrorWith` status401 -        it "succeeds if CSRF header and cookie match, and JWT is valid" $ \port -> property-                                                                       $ \(user :: User) -> do+        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 jwt-          let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"])-                               (xsrfCookieName cookieCfg <> "=blah")+          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) -      around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfg{xsrfExcludeGet = True}) $ do-        it "succeeds without CSRF header for GET when enabled, and JWT is valid"-              $ \port -> property-              $ \(user :: User) -> do+        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]++          resp <- postWith defaults (url port ++ "/login") user+          (resp ^. responseCookieJar) `shouldMatchCookieNames`+            [ sessionCookieName cookieCfg+            , xsrfField xsrfCookieName cookieCfg+            ]+          let loggedInOpts = optsFromResp resp++          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")+            , (xsrfField xsrfCookieName cookieCfg, "value")+            ]+          let loggedOutOpts = optsFromResp resp++          getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401++      describe "With no XSRF check for GET requests" $ let+            noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }+            cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }+       in around (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 jwt-          let opts = addCookie opts' (xsrfCookieName cookieCfg <> "=blah")+          opts <- addJwtToCookie cookieCfgNoXsrfGet 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 +      describe "With no XSRF check at all" $ let+            cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }+       in around (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 "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++        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 ++ "/logout")+          (resp ^. responseCookieJar) `shouldMatchCookieNameValues`+            [ (sessionCookieName cookieCfg, "value")+            , ("NO-XSRF-TOKEN", "")+            ]+          let loggedOutOpts = optsFromResp resp++          getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401+ -- }}} ------------------------------------------------------------------------------ -- * JWT Auth {{{@@ -315,6 +390,10 @@        :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)        :<|> "raw" :> Raw         )+      :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie+                                                                     , Header "Set-Cookie" SetCookie ] NoContent)+      :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie+                                             , Header "Set-Cookie" SetCookie ] NoContent)  jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) jwtOnlyApi = Proxy@@ -335,11 +414,16 @@  cookieCfg :: CookieSettings cookieCfg = def-  { xsrfCookieName = "TheyDinedOnMince"-  , xsrfHeaderName = "AndSlicesOfQuince"-  , cookieExpires = Just future+  { 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 ->@@ -357,7 +441,7 @@  appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User   => Proxy (API auths) -> CookieSettings -> Application-appWithCookie api ccfg = serveWithContext api ctx server+appWithCookie api ccfg = serveWithContext api ctx $ server ccfg   where     ctx = ccfg :. jwtCfg :. theKey :. EmptyContext @@ -366,14 +450,18 @@   => Proxy (API auths) -> Application app api = appWithCookie api cookieCfg -server :: Server (API auths)-server authResult = case authResult of-  Authenticated usr -> getInt usr-                  :<|> postInt usr-                  :<|> getHeaderInt-                  :<|> raw-  Indefinite -> throwAll err401-  _ -> throwAll err403+server :: CookieSettings -> Server (API auths)+server ccfg =+    (\authResult -> case authResult of+        Authenticated usr -> getInt usr+                        :<|> postInt usr+                        :<|> getHeaderInt+                        :<|> raw+        Indefinite -> throwAll err401+        _ -> throwAll err403+    )+    :<|> getLogin+    :<|> getLogout   where     getInt :: User -> Handler Int     getInt usr = return . length $ name usr@@ -384,6 +472,16 @@     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 = do+        Just applyCookies <- liftIO $ acceptLogin ccfg jwtCfg user+        return $ applyCookies NoContent++    getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie+                                   , Header "Set-Cookie" SetCookie ] NoContent)+    getLogout = return $ clearSession ccfg NoContent+     raw :: Server Raw     raw = #if MIN_VERSION_servant_server(0,11,0)@@ -411,11 +509,11 @@ createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT) createJWT k a b = runExceptT $ signClaims k a b -addJwtToCookie :: ToCompact a => Either Error a -> IO Options-addJwtToCookie jwt = case jwt >>= (return . encodeCompact) of+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" .~ ["JWT-Cookie=" <> BSL.toStrict v]+    $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]  addCookie :: Options -> BS.ByteString -> Options addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of@@ -430,10 +528,20 @@   HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)     -> HCli.responseStatus resp == stat #else-  StatusCodeException x _ _ -> x == stat+  HCli.StatusCodeException x _ _ -> x == stat #endif   _ -> False +shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation+shouldMatchCookieNames cj patterns+    = fmap cookie_name (destroyCookieJar cj)+    `shouldMatchList` patterns++shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation+shouldMatchCookieNameValues cj patterns+    = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)+    `shouldMatchList` patterns+ url :: Int -> String url port = "http://localhost:" <> show port @@ -455,5 +563,12 @@  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+    }+  -- }}}