diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 09419ac4a..aa711ce52 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -63,7 +63,7 @@ import qualified Servant.Types.SourceT as S import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai - (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, + (get, liftIO, matchHeaders, MatchHeader(..), matchStatus, shouldRespondWith, with, (<:>)) import qualified Test.Hspec.Wai as THW @@ -742,9 +742,9 @@ basicAuthServer = const (return jerry) :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") -basicAuthContext :: Context '[ BasicAuthCheck () ] -basicAuthContext = - let basicHandler = BasicAuthCheck True $ \(BasicAuthData usr pass) -> +basicAuthContext :: Bool -> Context '[ BasicAuthCheck () ] +basicAuthContext withRealm = + let basicHandler = BasicAuthCheck withRealm $ \(BasicAuthData usr pass) -> if usr == "servant" && pass == "server" then return (Authorized ()) else return Unauthorized @@ -753,7 +753,17 @@ basicAuthContext = basicAuthSpec :: Spec basicAuthSpec = 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 let basicAuthHeaders user password = @@ -761,6 +771,9 @@ basicAuthSpec = do it "returns 401 when no credentials given" $ do 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 THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") "" `shouldRespondWith` 403