eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add BasicAuth support to servant-server

Browse source
This commit is contained in:
aaron levin 2016-02-17 19:56:15 +01:00
parent 9966e5b304
commit 104ac29bf8
8 changed files with 214 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
servant-server/servant-server.cabal
View file

@ -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

7
servant-server/src/Servant/Server.hs
View file

@ -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 ())

25
servant-server/src/Servant/Server/Internal.hs
View file

@ -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

69
servant-server/src/Servant/Server/Internal/BasicAuth.hs Normal file
View file

@ -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] }

1
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

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

78
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -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 {{{

77
servant-server/test/Servant/ServerSpec.hs
View file

@ -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 {{{

1
servant/servant.cabal
View file

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