24531ac · typeable/servant

26import Data.Aeson.Lens (_JSON)

27import qualified Data.ByteString as BS

28import qualified Data.ByteString.Lazy as BSL

29−import Data.Text (Text)

29+import Data.Text (Text, pack)

30import Data.CaseInsensitive (mk)

31import Data.Foldable (find)

32import Data.Monoid

42import Network.Wai (responseLBS)

43import Network.Wai.Handler.Warp (testWithApplication)

44import Network.Wreq (Options, auth, basicAuth,

45+ checkResponse,

45 cookieExpiryTime, cookies,

46 cookieExpiryTime, cookies,

46 defaults, get, getWith, postWith,

47 defaults, get, getWith, postWith,

47 header, oauth2Bearer,

48 header, oauth2Bearer,

185 it "fails with no XSRF header or cookie" $ \port -> property

186 it "fails with no XSRF header or cookie" $ \port -> property

186 $ \(user :: User) -> do

187 $ \(user :: User) -> do

187 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

188 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

188− opts <- addJwtToCookie cookieCfg jwt

189+ opts' <- addJwtToCookie cookieCfg jwt

190+ let opts = opts' & checkResponse .~ Just mempty

189− getWith opts (url port) `shouldHTTPErrorWith` status401

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+

190

204

191 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

205 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

192 $ \(user :: User) -> do

206 $ \(user :: User) -> do

408 = Auth auths User :>

422 = Auth auths User :>

409 ( Get '[JSON] Int

423 ( Get '[JSON] Int

410 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

424 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

411− :<|> NamedRoutes DummyRoutes

425+ :<|> "named" :> NamedRoutes DummyRoutes

412− :<|> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 500 Text]

413 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

426 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

414#if MIN_VERSION_servant_server(0,15,0)

427#if MIN_VERSION_servant_server(0,15,0)

415 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

428 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

416#endif

429#endif

417 :<|> "raw" :> Raw

430 :<|> "raw" :> Raw

418 )

431 )

432+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]

419 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

433 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

420 , Header "Set-Cookie" SetCookie ] NoContent)

434 , Header "Set-Cookie" SetCookie ] NoContent)

421 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

435 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

486 Authenticated usr -> getInt usr

500 Authenticated usr -> getInt usr

487 :<|> postInt usr

501 :<|> postInt usr

488 :<|> DummyRoutes { dummyInt = getInt usr }

502 :<|> DummyRoutes { dummyInt = getInt usr }

489− :<|> respond (WithStatus @200 (42 :: Int))

490 :<|> getHeaderInt

503 :<|> getHeaderInt

491#if MIN_VERSION_servant_server(0,15,0)

504#if MIN_VERSION_servant_server(0,15,0)

492 :<|> return (S.source ["bytestring"])

505 :<|> return (S.source ["bytestring"])

494 :<|> raw

507 :<|> raw

495 Indefinite -> throwAll err401

508 Indefinite -> throwAll err401

496 _ -> throwAll err403

509 _ -> 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")

497 )

515 )

498 :<|> getLogin

516 :<|> getLogin

499 :<|> getLogout

517 :<|> getLogout

574 = fmap cookie_name (destroyCookieJar cj)

592 = fmap cookie_name (destroyCookieJar cj)

575 `shouldMatchList` patterns

593 `shouldMatchList` patterns

576

594

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+

577shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

601shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

578shouldMatchCookieNameValues cj patterns

602shouldMatchCookieNameValues cj patterns

579 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

603 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)