diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -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 + +~~~ diff --git a/executables/README.lhs b/executables/README.lhs deleted file mode 100644 --- a/executables/README.lhs +++ /dev/null @@ -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 - -~~~ diff --git a/servant-auth-server.cabal b/servant-auth-server.cabal --- a/servant-auth-server.cabal +++ b/servant-auth-server.cabal @@ -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: diff --git a/src/Servant/Auth/Server.hs b/src/Servant/Auth/Server.hs --- a/src/Servant/Auth/Server.hs +++ b/src/Servant/Auth/Server.hs @@ -67,18 +67,22 @@ -- ** Settings , CookieSettings(..) + , XsrfCookieSettings(..) , defaultCookieSettings + , defaultXsrfCookieSettings , makeSessionCookie , makeSessionCookieBS + , makeXsrfCookie , makeCsrfCookie , makeCookie , makeCookieBS , acceptLogin + , clearSession -- ** Related types , IsSecure(..) - + , SameSite(..) , AreAuths ---------------------------------------------------------------------------- diff --git a/src/Servant/Auth/Server/Internal.hs b/src/Servant/Auth/Server/Internal.hs --- a/src/Servant/Auth/Server/Internal.hs +++ b/src/Servant/Auth/Server/Internal.hs @@ -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 diff --git a/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/src/Servant/Auth/Server/Internal/ConfigTypes.hs --- a/src/Servant/Auth/Server/Internal/ConfigTypes.hs +++ b/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -1,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 -- }}} diff --git a/src/Servant/Auth/Server/Internal/Cookie.hs b/src/Servant/Auth/Server/Internal/Cookie.hs --- a/src/Servant/Auth/Server/Internal/Cookie.hs +++ b/src/Servant/Auth/Server/Internal/Cookie.hs @@ -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 diff --git a/src/Servant/Auth/Server/Internal/JWT.hs b/src/Servant/Auth/Server/Internal/JWT.hs --- a/src/Servant/Auth/Server/Internal/JWT.hs +++ b/src/Servant/Auth/Server/Internal/JWT.hs @@ -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) diff --git a/src/Servant/Auth/Server/Internal/Types.hs b/src/Servant/Auth/Server/Internal/Types.hs --- a/src/Servant/Auth/Server/Internal/Types.hs +++ b/src/Servant/Auth/Server/Internal/Types.hs @@ -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 diff --git a/test/Servant/Auth/ServerSpec.hs b/test/Servant/Auth/ServerSpec.hs --- a/test/Servant/Auth/ServerSpec.hs +++ b/test/Servant/Auth/ServerSpec.hs @@ -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 + } + -- }}}