eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

tests

Browse source
This commit is contained in:
Alexander Thiemann 2021-01-06 21:14:14 -08:00
parent 2d3b40dfeb
commit 4e894d4b92
1 changed files with 18 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
servant-server/test/Servant/ServerSpec.hs
View file

@ -63,7 +63,7 @@ import qualified Servant.Types.SourceT as S
import Test.Hspec import Test.Hspec
(Spec, context, describe, it, shouldBe, shouldContain) (Spec, context, describe, it, shouldBe, shouldContain)
import Test.Hspec.Wai import Test.Hspec.Wai
(get, liftIO, matchHeaders, matchStatus, shouldRespondWith, (get, liftIO, matchHeaders, MatchHeader(..), matchStatus, shouldRespondWith,
with, (<:>)) with, (<:>))
import qualified Test.Hspec.Wai as THW import qualified Test.Hspec.Wai as THW
@ -742,9 +742,9 @@ basicAuthServer =
const (return jerry) :<|> const (return jerry) :<|>
(Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext :: Bool -> Context '[ BasicAuthCheck () ]
basicAuthContext = basicAuthContext withRealm =
let basicHandler = BasicAuthCheck True $ \(BasicAuthData usr pass) -> let basicHandler = BasicAuthCheck withRealm $ \(BasicAuthData usr pass) ->
if usr == "servant" && pass == "server" if usr == "servant" && pass == "server"
then return (Authorized ()) then return (Authorized ())
else return Unauthorized else return Unauthorized
@ -753,7 +753,17 @@ basicAuthContext =
basicAuthSpec :: Spec basicAuthSpec :: Spec
basicAuthSpec = do basicAuthSpec = do
describe "Servant.API.BasicAuth" $ do describe "Servant.API.BasicAuth" $ do
with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do with (return (serveWithContext basicAuthApi (basicAuthContext False) basicAuthServer)) $ do
context "Basic Authentication without realm" $ do
it "does not send WWW-Authenticate headers on 401" $ do
let noWWW =
MatchHeader $ \headers _ ->
if "WWW-Authenticate" `elem` map fst headers
then Just "WWW-Authenticate header is unexpected, "
else Nothing
get "/basic" `shouldRespondWith` "" {matchStatus = 401, matchHeaders = [noWWW]}
with (return (serveWithContext basicAuthApi (basicAuthContext True) basicAuthServer)) $ do
context "Basic Authentication" $ do context "Basic Authentication" $ do
let basicAuthHeaders user password = let basicAuthHeaders user password =
@ -761,6 +771,9 @@ basicAuthSpec = do
it "returns 401 when no credentials given" $ do it "returns 401 when no credentials given" $ do
get "/basic" `shouldRespondWith` 401 get "/basic" `shouldRespondWith` 401
it "returns 401 WWW-Authenticate headers" $ do
get "/basic" `shouldRespondWith` "" {matchStatus = 401, matchHeaders = ["WWW-Authenticate" <:> "Basic realm=\"foo\""]}
it "returns 403 when invalid credentials given" $ do it "returns 403 when invalid credentials given" $ do
THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") "" THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") ""
`shouldRespondWith` 403 `shouldRespondWith` 403