Add BasicAuth support to servant-server

servant-server/servant-server.cabal

@@ -38,6 +38,7 @@ library
     Servant.Server
     Servant.Server.Internal
     Servant.Server.Internal.Context
+    Servant.Server.Internal.BasicAuth
     Servant.Server.Internal.Enter
     Servant.Server.Internal.Router
     Servant.Server.Internal.RoutingApplication
@@ -47,6 +48,7 @@ library
         base               >= 4.7  && < 5
       , aeson              >= 0.7  && < 0.12
       , attoparsec         >= 0.12 && < 0.14
+      , base64-bytestring  == 1.0.*
       , bytestring         >= 0.10 && < 0.11
       , containers         >= 0.5  && < 0.6
       , http-api-data      >= 0.1  && < 0.3
@@ -67,6 +69,7 @@ library
       , wai                >= 3.0  && < 3.3
       , wai-app-static     >= 3.0  && < 3.2
       , warp               >= 3.0  && < 3.3
+      , word8              == 0.1.*
 
   hs-source-dirs: src
   default-language: Haskell2010

servant-server/src/Servant/Server.hs

@@ -45,6 +45,11 @@ module Servant.Server
   , NamedContext(..)
   , descendIntoNamedContext
 
+
+  -- * Basic Authentication
+  , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
+  , BasicAuthResult(..)
+
     -- * Default error type
   , ServantErr(..)
     -- ** 3XX
@@ -119,7 +124,7 @@ serveWithContext :: (HasServer layout context)
     => Proxy layout -> Context context -> Server layout -> Application
 serveWithContext p context server = toApplication (runRouter (route p context d))
   where
-    d = Delayed r r r (\ _ _ -> Route server)
+    d = Delayed r r r r (\ _ _ _ -> Route server)
     r = return (Route ())
 
 

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

@@ -16,6 +16,7 @@
 module Servant.Server.Internal
   ( module Servant.Server.Internal
   , module Servant.Server.Internal.Context
+  , module Servant.Server.Internal.BasicAuth
   , module Servant.Server.Internal.Router
   , module Servant.Server.Internal.RoutingApplication
   , module Servant.Server.Internal.ServantErr
@@ -26,6 +27,7 @@ import           Control.Applicative         ((<$>))
 #endif
 import           Control.Monad.Trans.Except (ExceptT)
 import qualified Data.ByteString            as B
+import qualified Data.ByteString.Char8      as BC8
 import qualified Data.ByteString.Lazy       as BL
 import qualified Data.Map                   as M
 import           Data.Maybe                 (fromMaybe, mapMaybe)
@@ -48,7 +50,7 @@ import           Web.HttpApiData.Internal   (parseHeaderMaybe,
                                              parseQueryParamMaybe,
                                              parseUrlPieceMaybe)
 
-import           Servant.API                 ((:<|>) (..), (:>), Capture,
+import           Servant.API                 ((:<|>) (..), (:>), BasicAuth, Capture,
                                               Verb, ReflectMethod(reflectMethod),
                                               IsSecure(..), Header,
                                               QueryFlag, QueryParam, QueryParams,
@@ -63,6 +65,7 @@ import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
                                               getResponse)
 
 import           Servant.Server.Internal.Context
+import           Servant.Server.Internal.BasicAuth
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
@@ -450,6 +453,26 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where
   route Proxy context subserver = WithRequest $ \req ->
     route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
 
+-- * Basic Authentication
+
+-- | Basic Authentication
+instance ( KnownSymbol realm
+         , HasServer api config
+         , HasConfigEntry config (BasicAuthCheck usr)
+         )
+    => HasServer (BasicAuth realm usr :> api) config where
+
+  type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
+
+  route Proxy config subserver = WithRequest $ \ request ->
+    route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
+    where
+       realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
+       basicAuthConfig = getConfigEntry config
+       authCheck req = runBasicAuth req realm basicAuthConfig
+
+-- * helpers
+
 pathIsEmpty :: Request -> Bool
 pathIsEmpty = go . pathInfo
   where go []   = True

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

@@ -0,0 +1,69 @@
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings  #-}
+
+module Servant.Server.Internal.BasicAuth where
+
+import           Control.Monad          (guard)
+import qualified Data.ByteString        as BS
+import           Data.ByteString.Base64 (decodeLenient)
+import           Data.Monoid            ((<>))
+import           Data.Typeable          (Typeable)
+import           Data.Word8             (isSpace, toLower, _colon)
+import           GHC.Generics
+import           Network.HTTP.Types     (Header)
+import           Network.Wai            (Request, requestHeaders)
+
+import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
+import Servant.Server.Internal.RoutingApplication
+import Servant.Server.Internal.ServantErr
+
+-- * Basic Auth
+
+-- | servant-server's current implementation of basic authentication is not
+-- immune to certian kinds of timing attacks. Decoding payloads does not take
+-- a fixed amount of time.
+
+-- | The result of authentication/authorization
+data BasicAuthResult usr
+  = Unauthorized
+  | BadPassword
+  | NoSuchUser
+  | Authorized 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)
+  }
+  deriving (Generic, Typeable, Functor)
+
+-- | Internal method to make a basic-auth challenge
+mkBAChallengerHdr :: BS.ByteString -> Header
+mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"")
+
+-- | Find and decode an 'Authorization' header from the request as Basic Auth
+decodeBAHdr :: Request -> Maybe BasicAuthData
+decodeBAHdr req = do
+    ah <- lookup "Authorization" $ requestHeaders req
+    let (b, rest) = BS.break isSpace ah
+    guard (BS.map toLower b == "basic")
+    let decoded = decodeLenient (BS.dropWhile isSpace rest)
+    let (username, passWithColonAtHead) = BS.break (== _colon) decoded
+    (_, password) <- BS.uncons passWithColonAtHead
+    return (BasicAuthData username password)
+
+-- | Run and check basic authentication, returning the appropriate http error per
+-- the spec.
+runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)
+runBasicAuth req realm (BasicAuthCheck ba) =
+  case decodeBAHdr req of
+     Nothing -> plzAuthenticate
+     Just e  -> ba e >>= \res -> case res of
+       BadPassword    -> plzAuthenticate
+       NoSuchUser     -> plzAuthenticate
+       Unauthorized   -> return $ Fail err403
+       Authorized usr -> return $ Route usr
+  where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] }

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 module Servant.Server.Internal.RoutingApplication where
 

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.Server.ErrorSpec (spec) where
@@ -10,7 +11,8 @@ import           Data.Aeson                 (encode)
 import qualified Data.ByteString.Char8      as BC
 import qualified Data.ByteString.Lazy.Char8 as BCL
 import           Data.Proxy
-import           Network.HTTP.Types         (hAccept, hContentType, methodGet,
+import           Network.HTTP.Types         (hAccept, hAuthorization,
+                                             hContentType, methodGet,
                                              methodPost, methodPut)
 import           Safe                       (readMay)
 import           Test.Hspec
@@ -25,57 +27,79 @@ spec = describe "HTTP Errors" $ do
     errorRetrySpec
     errorChoiceSpec
 
+-- * Auth machinery (reused throughout)
+
+-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
+errorOrderAuthCheck :: BasicAuthCheck ()
+errorOrderAuthCheck =
+  let check (BasicAuthData username password) =
+        if username == "servant" && password == "server"
+        then return (Authorized ())
+        else return Unauthorized
+  in BasicAuthCheck check
+
 ------------------------------------------------------------------------------
 -- * Error Order {{{
 
 type ErrorOrderApi = "home"
+                  :> BasicAuth "error-realm" ()
                   :> ReqBody '[JSON] Int
                   :> Capture "t" Int
                   :> Post '[JSON] Int
 
-
 errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ -> throwE err402
+errorOrderServer = \_ _ _ -> throwE err402
 
 errorOrderSpec :: Spec
-errorOrderSpec = describe "HTTP error order"
+errorOrderSpec =
-           $ with (return $ serve errorOrderApi errorOrderServer) $ do
+  describe "HTTP error order" $
+    with (return $ serve errorOrderApi
+                   (errorOrderAuthCheck :. EmptyConfig)
+                   errorOrderServer
+         ) $ do
   let badContentType  = (hContentType, "text/plain")
       badAccept       = (hAccept, "text/plain")
       badMethod       = methodGet
       badUrl          = "home/nonexistent"
       badBody         = "nonsense"
+      badAuth         = (hAuthorization, "Basic foofoofoo")
       goodContentType = (hContentType, "application/json")
       goodAccept      = (hAccept, "application/json")
       goodMethod      = methodPost
       goodUrl         = "home/2"
       goodBody        = encode (5 :: Int)
+      -- username:password = servant:server
+      goodAuth        = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
 
   it "has 404 as its highest priority error" $ do
-    request badMethod badUrl [badContentType, badAccept] badBody
+    request badMethod badUrl [badAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 404
 
   it "has 405 as its second highest priority error" $ do
-    request badMethod goodUrl [badContentType, badAccept] badBody
+    request badMethod goodUrl [badAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 405
 
-  it "has 415 as its third highest priority error" $ do
+  it "has 401 as its third highest priority error (auth)" $ do
-    request goodMethod goodUrl [badContentType, badAccept] badBody
+    request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
+      `shouldRespondWith` 401
+
+  it "has 415 as its fourth highest priority error" $ do
+    request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 415
 
-  it "has 400 as its fourth highest priority error" $ do
+  it "has 400 as its fifth highest priority error" $ do
-    request goodMethod goodUrl [goodContentType, badAccept] badBody
+    request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody
       `shouldRespondWith` 400
 
-  it "has 406 as its fifth highest priority error" $ do
+  it "has 406 as its sixth highest priority error" $ do
-    request goodMethod goodUrl [goodContentType, badAccept] goodBody
+    request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody
       `shouldRespondWith` 406
 
   it "has handler-level errors as last priority" $ do
-    request goodMethod goodUrl [goodContentType, goodAccept] goodBody
+    request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
       `shouldRespondWith` 402
 
 type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
@@ -134,9 +158,12 @@ type ErrorRetryApi
   :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
   :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
   :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 4
-  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
+  :<|> "a" :> BasicAuth "bar-realm" ()
-  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 6
+           :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
-  :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 7
+  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 6
+
+  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 7
+  :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 8
 
 errorRetryApi :: Proxy ErrorRetryApi
 errorRetryApi = Proxy
@@ -148,13 +175,18 @@ errorRetryServer
   :<|> (\_ -> return 2)
   :<|> (\_ -> return 3)
   :<|> (\_ -> return 4)
-  :<|> (\_ -> return 5)
+  :<|> (\_ _ -> return 5)
   :<|> (\_ -> return 6)
   :<|> (\_ -> return 7)
+  :<|> (\_ -> return 8)
 
 errorRetrySpec :: Spec
-errorRetrySpec = describe "Handler search"
+errorRetrySpec =
-           $ with (return $ serve errorRetryApi errorRetryServer) $ do
+  describe "Handler search" $
+    with (return $ serve errorRetryApi
+                         (errorOrderAuthCheck :. EmptyConfig)
+                         errorRetryServer
+         ) $ do
 
   let jsonCT      = (hContentType, "application/json")
       jsonAccept  = (hAccept, "application/json")
@@ -162,16 +194,12 @@ errorRetrySpec = describe "Handler search"
 
   it "should continue when URLs don't match" $ do
     request methodPost "" [jsonCT, jsonAccept] jsonBody
-     `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }
+     `shouldRespondWith` 200 { matchBody = Just $ encode (8 :: Int) }
 
   it "should continue when methods don't match" $ do
     request methodGet "a" [jsonCT, jsonAccept] jsonBody
      `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
 
-  it "should not continue when body cannot be decoded" $ do
-    request methodPost "a" [jsonCT, jsonAccept] "a string"
-     `shouldRespondWith` 400
-
 -- }}}
 ------------------------------------------------------------------------------
 -- * Error Choice {{{

servant-server/test/Servant/ServerSpec.hs

@@ -38,8 +38,8 @@ import           Network.Wai.Internal       (Response (ResponseBuilder))
 import           Network.Wai.Test           (defaultRequest, request,
                                              runSession, simpleBody,
                                              simpleHeaders, simpleStatus)
-import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
+import           Servant.API                ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData),
-                                             Get, Header (..),
+                                             Capture, Delete, Get, Header (..),
                                              Headers, HttpVersion,
                                              IsSecure (..), JSON,
                                              NoContent (..), Patch, PlainText,
@@ -49,13 +49,16 @@ import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              StdMethod (..), Verb, addHeader)
 import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Server             (ServantErr (..), Server, err404,
-                                             serve, serveWithContext, Context(EmptyContext))
+                                             serve, serveWithContext, Context((:.), EmptyContext))
 import           Test.Hspec                 (Spec, context, describe, it,
                                              shouldBe, shouldContain)
+import qualified Test.Hspec.Wai             as THW
 import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
-                                             matchStatus, request,
+                                             matchStatus, shouldRespondWith,
-                                             shouldRespondWith, with, (<:>))
+                                             with, (<:>))
 
+import           Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),
+                                                    BasicAuthResult(Authorized,Unauthorized))
 import           Servant.Server.Internal.RoutingApplication
                                             (toApplication, RouteResult(..))
 import           Servant.Server.Internal.Router
@@ -86,6 +89,7 @@ spec = do
   responseHeadersSpec
   routerSpec
   miscCombinatorSpec
+  basicAuthSpec
 
 ------------------------------------------------------------------------------
 -- * verbSpec {{{
@@ -117,49 +121,49 @@ verbSpec = describe "Servant.API.Verb" $ do
           -- HEAD and 214/215 need not return bodies
           unless (status `elem` [214, 215] || method == methodHead) $
             it "returns the person" $ do
-              response <- Test.Hspec.Wai.request method "/" [] ""
+              response <- THW.request method "/" [] ""
               liftIO $ statusCode (simpleStatus response) `shouldBe` status
               liftIO $ decode' (simpleBody response) `shouldBe` Just alice
 
           it "returns no content on NoContent" $ do
-              response <- Test.Hspec.Wai.request method "/noContent" [] ""
+              response <- THW.request method "/noContent" [] ""
               liftIO $ statusCode (simpleStatus response) `shouldBe` status
               liftIO $ simpleBody response `shouldBe` ""
 
           -- HEAD should not return body
           when (method == methodHead) $
             it "HEAD returns no content body" $ do
-              response <- Test.Hspec.Wai.request method "/" [] ""
+              response <- THW.request method "/" [] ""
               liftIO $ simpleBody response `shouldBe` ""
 
           it "throws 405 on wrong method " $ do
-            Test.Hspec.Wai.request (wrongMethod method) "/" [] ""
+            THW.request (wrongMethod method) "/" [] ""
               `shouldRespondWith` 405
 
           it "returns headers" $ do
-            response1 <- Test.Hspec.Wai.request method "/header" [] ""
+            response1 <- THW.request method "/header" [] ""
             liftIO $ statusCode (simpleStatus response1) `shouldBe` status
             liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]
 
-            response2 <- Test.Hspec.Wai.request method "/header" [] ""
+            response2 <- THW.request method "/header" [] ""
             liftIO $ statusCode (simpleStatus response2) `shouldBe` status
             liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
 
           it "handles trailing '/' gracefully" $ do
-            response <- Test.Hspec.Wai.request method "/headerNC/" [] ""
+            response <- THW.request method "/headerNC/" [] ""
             liftIO $ statusCode (simpleStatus response) `shouldBe` status
 
           it "returns 406 if the Accept header is not supported" $ do
-            Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
+            THW.request method "" [(hAccept, "crazy/mime")] ""
               `shouldRespondWith` 406
 
           it "responds if the Accept header is supported" $ do
-            response <- Test.Hspec.Wai.request method ""
+            response <- THW.request method ""
                [(hAccept, "application/json")] ""
             liftIO $ statusCode (simpleStatus response) `shouldBe` status
 
           it "sets the Content-Type header" $ do
-            response <- Test.Hspec.Wai.request method "" [] ""
+            response <- THW.request method "" [] ""
             liftIO $ simpleHeaders response `shouldContain`
               [("Content-Type", "application/json")]
 
@@ -306,7 +310,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
 
   let server :: Server ReqBodyApi
       server = return :<|> return . age
-      mkReq method x = Test.Hspec.Wai.request method x
+      mkReq method x = THW.request method x
          [(hContentType, "application/json;charset=utf-8")]
 
   with (return $ serve reqBodyApi server) $ do
@@ -319,7 +323,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
       mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400
 
     it "responds with 415 if the request body media type is unsupported" $ do
-      Test.Hspec.Wai.request methodPost "/"
+      THW.request methodPost "/"
         [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
 
 -- }}}
@@ -455,19 +459,19 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
 
     it "includes the headers in the response" $
       forM_ methods $ \method ->
-        Test.Hspec.Wai.request method "/" [] ""
+        THW.request method "/" [] ""
           `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
                                       , matchStatus  = 200
                                       }
 
     it "responds with not found for non-existent endpoints" $
       forM_ methods $ \method ->
-        Test.Hspec.Wai.request method "blahblah" [] ""
+        THW.request method "blahblah" [] ""
           `shouldRespondWith` 404
 
     it "returns 406 if the Accept header is not supported" $
       forM_ methods $ \method ->
-        Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
+        THW.request method "" [(hAccept, "crazy/mime")] ""
           `shouldRespondWith` 406
 
 -- }}}
@@ -527,6 +531,39 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $
       go "/host" "\"0.0.0.0:0\""
 
   where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Authentication {{{
+------------------------------------------------------------------------------
+
+type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
+
+basicAuthApi :: Proxy BasicAuthAPI
+basicAuthApi = Proxy
+basicAuthServer :: Server BasicAuthAPI
+basicAuthServer = const (return jerry)
+
+basicAuthContext :: Context '[ BasicAuthCheck () ]
+basicAuthContext =
+  let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) ->
+        if usr == "servant" && pass == "server"
+        then return (Authorized ())
+        else return Unauthorized
+        )
+  in basicHandler :. EmptyContext
+
+basicAuthSpec :: Spec
+basicAuthSpec = do
+  describe "Servant.API.BasicAuth" $ do
+    with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do
+
+      context "Basic Authentication" $ do
+        it "returns with 401 with bad password" $ do
+          get "/basic" `shouldRespondWith` 401
+        it "returns 200 with the right password" $ do
+          THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * Test data types {{{

servant/servant.cabal

@@ -27,6 +27,7 @@ library
   exposed-modules:
     Servant.API
     Servant.API.Alternative
+    Servant.API.BasicAuth
     Servant.API.Capture
     Servant.API.ContentTypes
     Servant.API.Header