@@ -26,7 +26,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,
2626import Data.Aeson.Lens (_JSON)
2727import qualified Data.ByteString as BS
2828import qualified Data.ByteString.Lazy as BSL
29−import Data.Text (Text)
29+import Data.Text (Text, pack)
3030import Data.CaseInsensitive (mk)
3131import Data.Foldable (find)
3232import Data.Monoid
@@ -42,6 +42,7 @@ import Network.HTTP.Types (Status, status200,
4242import Network.Wai (responseLBS)
4343import Network.Wai.Handler.Warp (testWithApplication)
4444import Network.Wreq (Options, auth, basicAuth,
45+ checkResponse,
4546 cookieExpiryTime, cookies,
4647 defaults, get, getWith, postWith,
4748 header, oauth2Bearer,
@@ -185,8 +186,21 @@ cookieAuthSpec
185186 it "fails with no XSRF header or cookie" $ \port -> property
186187 $ \(user :: User) -> do
187188 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
188− opts <- addJwtToCookie cookieCfg jwt
189− getWith opts (url port) `shouldHTTPErrorWith` status401
189+ opts' <- addJwtToCookie cookieCfg jwt
190+ let opts = opts' & checkResponse .~ Just mempty
191+ resp <- getWith opts (url port)
192+ resp ^. responseStatus `shouldBe` status401
193+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
194+
195+ -- Validating that the XSRF cookie isn't added for UVerb routes either.
196+ -- These routes can return a 401 response directly without using throwError / throwAll,
197+ -- which revealed a bug:
198+ --
199+ -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
200+ resp <- getWith opts (url port ++ "/uverb")
201+ resp ^. responseStatus `shouldBe` status401
202+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
203+
190204
191205 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
192206 $ \(user :: User) -> do
@@ -408,14 +422,14 @@ type API auths
408422 = Auth auths User :>
409423 ( Get '[JSON] Int
410424 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
411− :<|> NamedRoutes DummyRoutes
412− :<|> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 500 Text]
425+ :<|> "named" :> NamedRoutes DummyRoutes
413426 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
414427#if MIN_VERSION_servant_server(0,15,0)
415428 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
416429#endif
417430 :<|> "raw" :> Raw
418431 )
432+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
419433 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
420434 , Header "Set-Cookie" SetCookie ] NoContent)
421435 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
@@ -486,7 +500,6 @@ server ccfg =
486500 Authenticated usr -> getInt usr
487501 :<|> postInt usr
488502 :<|> DummyRoutes { dummyInt = getInt usr }
489− :<|> respond (WithStatus @200 (42 :: Int))
490503 :<|> getHeaderInt
491504#if MIN_VERSION_servant_server(0,15,0)
492505 :<|> return (S.source ["bytestring"])
@@ -494,6 +507,11 @@ server ccfg =
494507 :<|> raw
495508 Indefinite -> throwAll err401
496509 _ -> throwAll err403
510+ ) :<|>
511+ (\authResult -> case authResult of
512+ Authenticated usr -> respond (WithStatus @200 (42 :: Int))
513+ Indefinite -> respond (WithStatus @401 $ pack "Authentication required")
514+ _ -> respond (WithStatus @403 $ pack "Forbidden")
497515 )
498516 :<|> getLogin
499517 :<|> getLogout
@@ -574,6 +592,12 @@ shouldMatchCookieNames cj patterns
574592 = fmap cookie_name (destroyCookieJar cj)
575593 `shouldMatchList` patterns
576594
595+shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
596+shouldNotHaveCookies cj patterns =
597+ sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns
598+ where cookieNames :: [BS.ByteString]
599+ cookieNames = cookie_name <$> destroyCookieJar cj
600+
577601shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
578602shouldMatchCookieNameValues cj patterns
579603 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)