diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 9a23a4d7..2aa25cee 100644 --- a/servant-server/servant-server.cabal +++ b/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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 70fae733..6b37297e 100644 --- a/servant-server/src/Servant/Server.hs +++ b/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 ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 05450649..bdf7451f 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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 diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs new file mode 100644 index 00000000..f941f401 --- /dev/null +++ b/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] } diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 7e846504..cd1ac019 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/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 diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 3575e2ac..5ae22361 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/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" - $ with (return $ serve errorOrderApi errorOrderServer) $ do +errorOrderSpec = + 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 - request goodMethod goodUrl [badContentType, badAccept] badBody + it "has 401 as its third highest priority error (auth)" $ do + 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 - request goodMethod goodUrl [goodContentType, badAccept] badBody + it "has 400 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody `shouldRespondWith` 400 - it "has 406 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] goodBody + it "has 406 as its sixth highest priority error" $ do + 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 - :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6 - :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7 + :<|> "a" :> BasicAuth "bar-realm" () + :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 + :<|> "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" - $ with (return $ serve errorRetryApi errorRetryServer) $ do +errorRetrySpec = + 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 {{{ diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 6bf9defc..71f1bd9f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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, - Get, Header (..), +import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData), + 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, - shouldRespondWith, with, (<:>)) + matchStatus, shouldRespondWith, + 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 {{{ diff --git a/servant/servant.cabal b/servant/servant.cabal index 1b5e3c27..56e4580e 100644 --- a/servant/servant.cabal +++ b/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