Merge 4e894d4b92 into ad25e98e19

servant-client/test/Servant/ClientTestUtils.hs

@@ -296,7 +296,7 @@ basicAuthHandler =
         if username == "servant" && password == "server"
         then return (Authorized ())
         else return Unauthorized
-  in BasicAuthCheck check
+  in BasicAuthCheck True check
 
 basicServerContext :: Context '[ BasicAuthCheck () ]
 basicServerContext = basicAuthHandler :. EmptyContext

servant-http-streams/test/Servant/ClientSpec.hs

@@ -220,7 +220,7 @@ basicAuthHandler =
         if username == "servant" && password == "server"
         then return (Authorized ())
         else return Unauthorized
-  in BasicAuthCheck check
+  in BasicAuthCheck True check
 
 basicServerContext :: Context '[ BasicAuthCheck () ]
 basicServerContext = basicAuthHandler :. EmptyContext

servant-server/src/Servant/Server.hs

@@ -46,7 +46,7 @@ module Servant.Server
   , descendIntoNamedContext
 
   -- * Basic Authentication
-  , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
+  , BasicAuthCheck(BasicAuthCheck, basicAuthRunCheck, basicAuthPresentChallenge)
   , BasicAuthResult(..)
 
   -- * General Authentication

servant-server/src/Servant/Server/Internal/BasicAuth.hs

@@ -42,9 +42,12 @@ data BasicAuthResult usr
   deriving (Eq, Show, Read, Generic, Typeable, Functor)
 
 -- | Datatype wrapping a function used to check authentication.
-newtype BasicAuthCheck usr = BasicAuthCheck
-  { unBasicAuthCheck :: BasicAuthData
-                     -> IO (BasicAuthResult usr)
+data BasicAuthCheck usr 
+  = BasicAuthCheck
+  { basicAuthPresentChallenge :: Bool
+    -- ^ Decides if we'll send a @WWW-Authenticate@ HTTP header. Sending the header causes browser to 
+    -- surface a prompt for user name and password, which may be undesirable for APIs.
+  , basicAuthRunCheck :: BasicAuthData -> IO (BasicAuthResult usr)
   }
   deriving (Generic, Typeable, Functor)
 
@@ -66,7 +69,7 @@ decodeBAHdr req = do
 -- | Run and check basic authentication, returning the appropriate http error per
 -- the spec.
 runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr
-runBasicAuth req realm (BasicAuthCheck ba) =
+runBasicAuth req realm (BasicAuthCheck presentChallenge ba) =
   case decodeBAHdr req of
      Nothing -> plzAuthenticate
      Just e  -> liftIO (ba e) >>= \res -> case res of
@@ -74,4 +77,6 @@ runBasicAuth req realm (BasicAuthCheck ba) =
        NoSuchUser     -> plzAuthenticate
        Unauthorized   -> delayedFailFatal err403
        Authorized usr -> return usr
-  where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }
+  where 
+    plzAuthenticate = 
+      delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm | presentChallenge] }

servant-server/test/Servant/Server/ErrorSpec.hs

@@ -42,7 +42,7 @@ errorOrderAuthCheck =
         if username == "servant" && password == "server"
         then return (Authorized ())
         else return Unauthorized
-  in BasicAuthCheck check
+  in BasicAuthCheck True check
 
 ------------------------------------------------------------------------------
 -- * Error Order {{{

servant-server/test/Servant/ServerSpec.hs

@@ -64,7 +64,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
 
@@ -769,9 +769,9 @@ basicAuthServer =
   const (return jerry) :<|>
   (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
 
-basicAuthContext :: Context '[ BasicAuthCheck () ]
-basicAuthContext =
-  let basicHandler = BasicAuthCheck $ \(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
@@ -780,7 +780,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 =
@@ -788,6 +798,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