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

Merge pull request #375 from haskell-servant/auth-basic

Browse source 
Basic Authentication Support
This commit is contained in:
Aaron Levin 2016-03-08 23:55:58 +01:00
commit 51dbd82c16
21 changed files with 560 additions and 75 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client/CHANGELOG.md
View file

@ -8,6 +8,7 @@ HEAD
* Use `http-api-data` instead of `Servant.Common.Text`
* Client functions now consider any 2xx successful.
* Remove matrix params.
* Added support for Basic authentication
0.4.1
-----

2
servant-client/servant-client.cabal
View file

@ -28,11 +28,13 @@ library
exposed-modules:
Servant.Client
Servant.Common.BaseUrl
Servant.Common.BasicAuth
Servant.Common.Req
build-depends:
base >=4.7 && <5
, aeson
, attoparsec
, base64-bytestring
, bytestring
, exceptions
, http-api-data >= 0.1 && < 0.3

10
servant-client/src/Servant/Client.hs
View file

@ -37,6 +37,7 @@ import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
import Servant.API
import Servant.Common.BaseUrl
import Servant.Common.BasicAuth
import Servant.Common.Req
-- * Accessing APIs as a Client
@ -424,6 +425,15 @@ instance HasClient subapi =>
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
-- * Basic Authentication
instance HasClient api => HasClient (BasicAuth realm usr :> api) where
type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
clientWithRoute Proxy req baseurl manager val =
clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager
{- Note [Non-Empty Content Types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Rather than have

21
servant-client/src/Servant/Common/BasicAuth.hs Normal file
View file

@ -0,0 +1,21 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
-- | Basic Authentication for clients
module Servant.Common.BasicAuth (
basicAuthReq
) where
import Data.ByteString.Base64 (encode)
import Data.Monoid ((<>))
import Data.Text.Encoding (decodeUtf8)
import Servant.Common.Req (addHeader, Req)
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
-- | Authenticate a request using Basic Authentication
basicAuthReq :: BasicAuthData -> Req -> Req
basicAuthReq (BasicAuthData user pass) req =
let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
in addHeader "Authorization" authText req

40
servant-client/test/Servant/ClientSpec.hs
View file

@ -62,6 +62,7 @@ spec = describe "Servant.Client" $ do
sucessSpec
failSpec
wrappedApiSpec
basicAuthSpec
-- * test data types
@ -148,6 +149,29 @@ failServer = serve failApi (
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
)
-- * auth stuff
type BasicAuthAPI =
BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
basicAuthAPI :: Proxy BasicAuthAPI
basicAuthAPI = Proxy
basicAuthHandler :: BasicAuthCheck ()
basicAuthHandler =
let check (BasicAuthData username password) =
if username == "servant" && password == "server"
then return (Authorized ())
else return Unauthorized
in BasicAuthCheck check
serverContext :: Context '[ BasicAuthCheck () ]
serverContext = basicAuthHandler :. EmptyContext
basicAuthServer :: Application
basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice))
{-# NOINLINE manager #-}
manager :: C.Manager
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@ -292,6 +316,22 @@ data WrappedApi where
HasClient api, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi
basicAuthSpec :: Spec
basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
context "Authentication works when requests are properly authenticated" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI baseUrl manager
let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runExceptT (getBasic basicAuthData)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI baseUrl manager
let basicAuthData = BasicAuthData "not" "password"
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)
responseStatus `shouldBe` Status 403 "Forbidden"
-- * utils

1
servant-docs/CHANGELOG.md
View file

@ -9,6 +9,7 @@ HEAD
* Move `toSample` out of `ToSample` class
* Add a few helper functions to define `toSamples`
* Remove matrix params.
* Added support for Basic authentication
0.4
---

45
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -22,7 +22,7 @@ module Servant.Docs.Internal where
import Control.Applicative
import Control.Arrow (second)
import Control.Lens (makeLenses, over, traversed, (%~),
import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
(&), (.~), (<>~), (^.), (|>))
import qualified Control.Monad.Omega as Omega
import Data.ByteString.Conversion (ToByteString, toByteString)
@ -140,6 +140,12 @@ data DocIntro = DocIntro
, _introBody :: [String] -- ^ Each String is a paragraph.
} deriving (Eq, Show)
-- | A type to represent Authentication information about an endpoint.
data DocAuthentication = DocAuthentication
{ _authIntro :: String
, _authDataRequired :: String
} deriving (Eq, Ord, Show)
instance Ord DocIntro where
compare = comparing _introTitle
@ -230,7 +236,8 @@ defResponse = Response
-- You can tweak an 'Action' (like the default 'defAction') with these lenses
-- to transform an action and add some information to it.
data Action = Action
{ _captures :: [DocCapture] -- type collected + user supplied info
{ _authInfo :: [DocAuthentication] -- user supplied info
, _captures :: [DocCapture] -- type collected + user supplied info
, _headers :: [Text] -- type collected
, _params :: [DocQueryParam] -- type collected + user supplied info
, _notes :: [DocNote] -- user supplied
@ -247,8 +254,8 @@ data Action = Action
-- 'combineAction' to mush two together taking the response, body and content
-- types from the very left.
combineAction :: Action -> Action -> Action
Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
-- Default 'Action'. Has no 'captures', no GET 'params', expects
-- no request body ('rqbody') and the typical response is 'defResponse'.
@ -268,6 +275,7 @@ defAction =
[]
[]
[]
[]
defResponse
-- | Create an API that's comprised of a single endpoint.
@ -277,6 +285,7 @@ single :: Endpoint -> Action -> API
single e a = API mempty (HM.singleton e a)
-- gimme some lenses
makeLenses ''DocAuthentication
makeLenses ''DocOptions
makeLenses ''API
makeLenses ''Endpoint
@ -454,7 +463,7 @@ instance AllHeaderSamples '[] where
instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
=> AllHeaderSamples (Header h l ': ls) where
allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :
allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
allHeaderToSample (Proxy :: Proxy ls)
where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
mkHeader (Just x) = (headerName, cs $ toByteString x)
@ -504,6 +513,10 @@ class ToParam t where
class ToCapture c where
toCapture :: Proxy c -> DocCapture
-- | The class that helps us get documentation for authenticated endpoints
class ToAuthInfo a where
toAuthInfo :: Proxy a -> DocAuthentication
-- | Generate documentation in Markdown format for
-- the given 'API'.
markdown :: API -> String
@ -516,6 +529,7 @@ markdown api = unlines $
str :
"" :
notesStr (action ^. notes) ++
authStr (action ^. authInfo) ++
capturesStr (action ^. captures) ++
headersStr (action ^. headers) ++
paramsStr (action ^. params) ++
@ -548,6 +562,20 @@ markdown api = unlines $
"" :
[]
authStr :: [DocAuthentication] -> [String]
authStr auths =
let authIntros = mapped %~ view authIntro $ auths
clientInfos = mapped %~ view authDataRequired $ auths
in "#### Authentication":
"":
unlines authIntros :
"":
"Clients must supply the following data" :
unlines clientInfos :
"" :
[]
capturesStr :: [DocCapture] -> [String]
capturesStr [] = []
capturesStr l =
@ -797,6 +825,13 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where
docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor (Proxy :: Proxy sublayout) (endpoint, action')
where
authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action
-- ToSample instances for simple types
instance ToSample ()
instance ToSample Bool

105
servant-examples/basic-auth/basic-auth.hs Normal file
View file

@ -0,0 +1,105 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Data.Aeson (ToJSON)
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)
import GHC.Generics (Generic)
import Network.Wai.Handler.Warp (run)
import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
Get, JSON)
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.Server (BasicAuthCheck (BasicAuthCheck),
BasicAuthResult( Authorized
, Unauthorized
),
Context ((:.), EmptyContext), Server,
serveWithContext)
-- | let's define some types that our API returns.
-- | private data that needs protection
newtype PrivateData = PrivateData { ssshhh :: Text }
deriving (Eq, Show, Generic)
instance ToJSON PrivateData
-- | public data that anyone can use.
newtype PublicData = PublicData { somedata :: Text }
deriving (Eq, Show, Generic)
instance ToJSON PublicData
-- | A user we'll grab from the database when we authenticate someone
newtype User = User { userName :: Text }
deriving (Eq, Show)
-- | a type to wrap our public api
type PublicAPI = Get '[JSON] [PublicData]
-- | a type to wrap our private api
type PrivateAPI = Get '[JSON] PrivateData
-- | our API
type API = "public" :> PublicAPI
:<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI
-- | a value holding a proxy of our API type
api :: Proxy API
api = Proxy
-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
authCheck :: BasicAuthCheck User
authCheck =
let check (BasicAuthData username password) =
if username == "servant" && password == "server"
then return (Authorized (User "servant"))
else return Unauthorized
in BasicAuthCheck check
-- | We need to supply our handlers with the right Context. In this case,
-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
-- to the BasicAuth HasServer handlers.
serverContext :: Context (BasicAuthCheck User ': '[])
serverContext = authCheck :. EmptyContext
-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
-- In particular, for the BasicAuth protected handler, we need to supply a function
-- that takes 'User' as an argument.
server :: Server API
server =
let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
privateAPIHandler (user :: User) = return (PrivateData (userName user))
in publicAPIHandler :<|> privateAPIHandler
-- | hello, server!
main :: IO ()
main = run 8080 (serveWithContext api serverContext server)
{- Sample session
$ curl -XGET localhost:8080/public
[{"somedata":"foo"},{"somedata":"bar"}
$ curl -iXGET localhost:8080/private
HTTP/1.1 401 Unauthorized
transfer-encoding: chunked
Date: Thu, 07 Jan 2016 22:36:38 GMT
Server: Warp/3.1.8
WWW-Authenticate: Basic realm="foo-realm"
$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI="
HTTP/1.1 200 OK
transfer-encoding: chunked
Date: Thu, 07 Jan 2016 22:37:58 GMT
Server: Warp/3.1.8
Content-Type: application/json
{"ssshhh":"servant"}
-}

16
servant-examples/servant-examples.cabal
View file

@ -89,6 +89,22 @@ executable wai-middleware
hs-source-dirs: wai-middleware
default-language: Haskell2010
executable basic-auth
main-is: basic-auth.hs
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
build-depends:
aeson >= 0.8
, base >= 4.7 && < 5
, bytestring
, http-types
, servant == 0.5.*
, servant-server == 0.5.*
, text
, wai
, warp
hs-source-dirs: basic-auth
default-language: Haskell2010
executable auth-combinator
main-is: auth-combinator.hs
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing

1
servant-server/CHANGELOG.md
View file

@ -11,6 +11,7 @@ HEAD
* Remove `RouteMismatch`.
* Redefined constructors of `RouteResult`.
* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)
* Added support for Basic Authentication
0.4.1
-----

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 context
, HasContextEntry context (BasicAuthCheck usr)
)
=> HasServer (BasicAuth realm usr :> api) context where
type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
where
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
basicAuthContext = getContextEntry context
authCheck req = runBasicAuth req realm basicAuthContext
-- * 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] }

93
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
@ -52,6 +53,7 @@ toApplication ra request respond = ra request routingRespond
-- static routes (can cause 404)
-- delayed captures (can cause 404)
-- methods (can cause 405)
-- authentication and authorization (can cause 401, 403)
-- delayed body (can cause 415, 400)
-- accept header (can cause 406)
--
@ -119,36 +121,71 @@ toApplication ra request respond = ra request routingRespond
-- The accept header check can be performed as the final
-- computation in this block. It can cause a 406.
--
data Delayed :: * -> * where
Delayed :: IO (RouteResult a)
-> IO (RouteResult ())
-> IO (RouteResult b)
-> (a -> b -> RouteResult c)
-> Delayed c
data Delayed c where
Delayed :: { capturesD :: IO (RouteResult captures)
, methodD :: IO (RouteResult ())
, authD :: IO (RouteResult auth)
, bodyD :: IO (RouteResult body)
, serverD :: (captures -> auth -> body -> RouteResult c)
} -> Delayed c
instance Functor Delayed where
fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g)
fmap f Delayed{..}
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = authD
, bodyD = bodyD
, serverD = (fmap.fmap.fmap.fmap) f serverD
} -- Note [Existential Record Update]
-- | Add a capture to the end of the capture block.
addCapture :: Delayed (a -> b)
-> IO (RouteResult a)
-> Delayed b
addCapture (Delayed captures method body server) new =
Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)
addCapture Delayed{..} new
= Delayed { capturesD = combineRouteResults (,) capturesD new
, methodD = methodD
, authD = authD
, bodyD = bodyD
, serverD = \ (x, v) y z -> ($ v) <$> serverD x y z
} -- Note [Existential Record Update]
-- | Add a method check to the end of the method block.
addMethodCheck :: Delayed a
-> IO (RouteResult ())
-> Delayed a
addMethodCheck (Delayed captures method body server) new =
Delayed captures (combineRouteResults const method new) body server
addMethodCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = combineRouteResults const methodD new
, authD = authD
, bodyD = bodyD
, serverD = serverD
} -- Note [Existential Record Update]
-- | Add an auth check to the end of the auth block.
addAuthCheck :: Delayed (a -> b)
-> IO (RouteResult a)
-> Delayed b
addAuthCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = combineRouteResults (,) authD new
, bodyD = bodyD
, serverD = \ x (y, v) z -> ($ v) <$> serverD x y z
} -- Note [Existential Record Update]
-- | Add a body check to the end of the body block.
addBodyCheck :: Delayed (a -> b)
-> IO (RouteResult a)
-> Delayed b
addBodyCheck (Delayed captures method body server) new =
Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)
addBodyCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = authD
, bodyD = combineRouteResults (,) bodyD new
, serverD = \ x y (z, v) -> ($ v) <$> serverD x y z
} -- Note [Existential Record Update]
-- | Add an accept header check to the end of the body block.
-- The accept header check should occur after the body check,
@ -157,8 +194,13 @@ addBodyCheck (Delayed captures method body server) new =
addAcceptCheck :: Delayed a
-> IO (RouteResult ())
-> Delayed a
addAcceptCheck (Delayed captures method body server) new =
Delayed captures method (combineRouteResults const body new) server
addAcceptCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = authD
, bodyD = combineRouteResults const bodyD new
, serverD = serverD
} -- Note [Existential Record Update]
-- | Many combinators extract information that is passed to
-- the handler without the possibility of failure. In such a
@ -190,13 +232,17 @@ combineRouteResults f m1 m2 =
-- | Run a delayed server. Performs all scheduled operations
-- in order, and passes the results from the capture and body
-- blocks on to the actual handler.
--
-- This should only be called once per request; otherwise the guarantees about
-- effect and HTTP error ordering break down.
runDelayed :: Delayed a
-> IO (RouteResult a)
runDelayed (Delayed captures method body server) =
captures `bindRouteResults` \ c ->
method `bindRouteResults` \ _ ->
body `bindRouteResults` \ b ->
return (server c b)
runDelayed Delayed{..} =
capturesD `bindRouteResults` \ c ->
methodD `bindRouteResults` \ _ ->
authD `bindRouteResults` \ a ->
bodyD `bindRouteResults` \ b ->
return (serverD c a b)
-- | Runs a delayed server and the resulting action.
-- Takes a continuation that lets us send a response.
@ -215,3 +261,10 @@ runAction action respond k = runDelayed action >>= go >>= respond
case e of
Left err -> return . Route $ responseServantErr err
Right x -> return $! k x
{- Note [Existential Record Update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
do the more succint thing - just update the records we actually change.
-}

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 $ serveWithContext errorOrderApi
(errorOrderAuthCheck :. EmptyContext)
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 $ serveWithContext errorRetryApi
(errorOrderAuthCheck :. EmptyContext)
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 {{{

83
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,20 +49,23 @@ 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
(tweakResponse, runRouter,
Router, Router'(LeafRouter))
import Servant.Server.Internal.Context
(Context(..), NamedContext(..))
(NamedContext(..))
-- * comprehensive api test
@ -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
-- }}}
@ -343,13 +347,13 @@ headerSpec = describe "Servant.API.Header" $ do
expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
let delete' x = THW.request methodDelete x [("MyHeader", "5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 200
with (return (serve headerApi expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
let delete' x = THW.request methodDelete x [("MyHeader", "more from you")]
it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 200
@ -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/CHANGELOG.md
View file

@ -10,6 +10,7 @@ HEAD
* Add PlainText String MimeRender and MimeUnrender instances.
* Add new `Verbs` combinator, and make all existing and new verb combinators
type synonyms of it.
* Add `BasicAuth` combinator to support Basic authentication
0.4.2
-----

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

4
servant/src/Servant/API.hs
View file

@ -29,6 +29,9 @@ module Servant.API (
-- * Actual endpoints, distinguished by HTTP method
module Servant.API.Verbs,
-- * Authentication
module Servant.API.BasicAuth,
-- * Content Types
module Servant.API.ContentTypes,
-- | Serializing and deserializing types based on @Accept@ and
@ -51,6 +54,7 @@ module Servant.API (
) where
import Servant.API.Alternative ((:<|>) (..))
import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))
import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON,

29
servant/src/Servant/API/BasicAuth.hs Normal file
View file

@ -0,0 +1,29 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
module Servant.API.BasicAuth where
import Data.ByteString (ByteString)
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
-- | Combinator for <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>.
--
-- *IMPORTANT*: Only use Basic Auth over HTTPS! Credentials are not hashed or
-- encrypted. Note also that because the same credentials are sent on every
-- request, Basic Auth is not as secure as some alternatives. Further, the
-- implementation in servant-server does not protect against some types of
-- timing attacks.
--
-- In Basic Auth, username and password are base64-encoded and transmitted via
-- the @Authorization@ header. Handshakes are not required, making it
-- relatively efficient.
data BasicAuth (realm :: Symbol) (userData :: *)
deriving (Typeable)
-- | A simple datatype to hold data required to decorate a request
data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString
, basicAuthPassword :: !ByteString
}