From 14ff2197268c02cb47b311abae1d4591f1b34704 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?S=C3=B6nke=20Hahn?= <soenkehahn@gmail.com>
Date: Wed, 6 Apr 2016 11:16:18 +0800
Subject: [PATCH] fix error status bug in basic auth

Fixes #440.
---
 .../src/Servant/Server/Internal/BasicAuth.hs  |  4 ++--
 servant-server/test/Servant/ServerSpec.hs     | 19 ++++++++++++++++---
 2 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs
index 2f430417..fcd678b5 100644
--- a/servant-server/src/Servant/Server/Internal/BasicAuth.hs
+++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs
@@ -64,6 +64,6 @@ runBasicAuth req realm (BasicAuthCheck ba) =
      Just e  -> ba e >>= \res -> case res of
        BadPassword    -> plzAuthenticate
        NoSuchUser     -> plzAuthenticate
-       Unauthorized   -> return $ Fail err403
+       Unauthorized   -> return $ FailFatal err403
        Authorized usr -> return $ Route usr
-  where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] }
+  where plzAuthenticate = return $ FailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }
diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs
index 2e066582..31bdadd1 100644
--- a/servant-server/test/Servant/ServerSpec.hs
+++ b/servant-server/test/Servant/ServerSpec.hs
@@ -30,6 +30,7 @@ import           Network.HTTP.Types         (Status (..), hAccept, hContentType,
                                              methodDelete, methodGet,
                                              methodHead, methodPatch,
                                              methodPost, methodPut, ok200,
+                                             imATeaPot418,
                                              parseQuery)
 import           Network.Wai                (Application, Request, requestHeaders, pathInfo,
                                              queryString, rawQueryString,
@@ -542,13 +543,17 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $
 -- * Basic Authentication {{{
 ------------------------------------------------------------------------------
 
-type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
+type BasicAuthAPI =
+       BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
+  :<|> Raw
 
 basicAuthApi :: Proxy BasicAuthAPI
 basicAuthApi = Proxy
 
 basicAuthServer :: Server BasicAuthAPI
-basicAuthServer = const (return jerry)
+basicAuthServer =
+  const (return jerry) :<|>
+  (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
 
 basicAuthContext :: Context '[ BasicAuthCheck () ]
 basicAuthContext =
@@ -564,14 +569,22 @@ basicAuthSpec = do
     with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do
 
       context "Basic Authentication" $ do
-        it "returns 401 with bad password" $ do
+        it "returns 401 when no credentials given" $ do
           get "/basic" `shouldRespondWith` 401
 
+        it "returns 403 when invalid credentials given" $ do
+          let invalid = [("Authorization", "Basic bbbbbbbbbDpzZXJ2ZXI=")] -- fixme: how do I create basic auth tokens?
+          THW.request methodGet "/basic" invalid ""
+            `shouldRespondWith` 403
+
         it "returns 200 with the right password" $ do
           let validCredentials = [("Authorization", "Basic c2VydmFudDpzZXJ2ZXI=")]
           THW.request methodGet "/basic" validCredentials ""
             `shouldRespondWith` 200
 
+        it "plays nice with subsequent Raw endpoints" $ do
+          get "/foo" `shouldRespondWith` 418
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * General Authentication {{{