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

Add Config parameter.

Browse source 
This allows combinator instances to receive dynamic data that isn't
        constrained by the interface of Delayed etc.
This commit is contained in:
Julian K. Arni 2015-12-26 14:32:43 +01:00
parent 4a03c6e8b5
commit d0cd0c8c2f
9 changed files with 160 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
servant-server/example/greet.hs
View file

@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
-- Turn the server into a WAI app. 'serve' is provided by servant, -- Turn the server into a WAI app. 'serve' is provided by servant,
-- more precisely by the Servant.Server module. -- more precisely by the Servant.Server module.
test :: Application test :: Application
test = serve testApi server test = serve testApi EmptyConfig server
-- Run the server. -- Run the server.
-- --

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

@ -36,6 +36,7 @@ library
Servant Servant
Servant.Server Servant.Server
Servant.Server.Internal Servant.Server.Internal
Servant.Server.Internal.Config
Servant.Server.Internal.Enter Servant.Server.Internal.Enter
Servant.Server.Internal.Router Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication Servant.Server.Internal.RoutingApplication

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

@ -35,6 +35,11 @@ module Servant.Server
, generalizeNat , generalizeNat
, tweakResponse , tweakResponse
-- * Config
, ConfigEntry(..)
, Config(..)
, (.:)
-- * Default error type -- * Default error type
, ServantErr(..) , ServantErr(..)
-- ** 3XX -- ** 3XX
@ -96,14 +101,17 @@ import Servant.Server.Internal.Enter
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > cfg :: Config '[]
-- > cfg = EmptyConfig
-- >
-- > app :: Application -- > app :: Application
-- > app = serve myApi server -- > app = serve myApi cfg server
-- > -- >
-- > main :: IO () -- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
-- --
serve :: HasServer layout => Proxy layout -> Server layout -> Application serve :: HasServer layout => Proxy layout -> Config a -> Server layout -> Application
serve p server = toApplication (runRouter (route p d)) serve p cfg server = toApplication (runRouter (route p cfg d))
where where
d = Delayed r r r (\ _ _ -> Route server) d = Delayed r r r (\ _ _ -> Route server)
r = return (Route ()) r = return (Route ())

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

@ -14,6 +14,7 @@
module Servant.Server.Internal module Servant.Server.Internal
( module Servant.Server.Internal ( module Servant.Server.Internal
, module Servant.Server.Internal.Config
, module Servant.Server.Internal.Router , module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr , module Servant.Server.Internal.ServantErr
@ -52,6 +53,7 @@ import Servant.API.ContentTypes (AcceptHeader (..),
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
getResponse) getResponse)
import Servant.Server.Internal.Config
import Servant.Server.Internal.Router import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
@ -62,7 +64,7 @@ import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe,
class HasServer layout where class HasServer layout where
type ServerT layout (m :: * -> *) :: * type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Delayed (Server layout) -> Router route :: Proxy layout -> Config a -> Delayed (Server layout) -> Router
type Server layout = ServerT layout (ExceptT ServantErr IO) type Server layout = ServerT layout (ExceptT ServantErr IO)
@ -83,8 +85,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server)) route Proxy cfg server = choice (route pa cfg ((\ (a :<|> _) -> a) <$> server))
(route pb ((\ (_ :<|> b) -> b) <$> server)) (route pb cfg ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b pb = Proxy :: Proxy b
@ -114,9 +116,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
type ServerT (Capture capture a :> sublayout) m = type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy d = route Proxy cfg d =
DynamicRouter $ \ first -> DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout) route (Proxy :: Proxy sublayout)
cfg
(addCapture d $ case captured captureProxy first of (addCapture d $ case captured captureProxy first of
Nothing -> return $ Fail err404 Nothing -> return $ Fail err404
Just v -> return $ Route v Just v -> return $ Route v
@ -215,7 +218,7 @@ instance
type ServerT (Delete ctypes a) m = m a type ServerT (Delete ctypes a) m = m a
route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -225,7 +228,7 @@ instance
type ServerT (Delete ctypes ()) m = m () type ServerT (Delete ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodDelete route Proxy _ = methodRouterEmpty methodDelete
-- Add response headers -- Add response headers
instance instance
@ -237,7 +240,7 @@ instance
type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-- | When implementing the handler for a 'Get' endpoint, -- | When implementing the handler for a 'Get' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
@ -260,7 +263,7 @@ instance
type ServerT (Get ctypes a) m = m a type ServerT (Get ctypes a) m = m a
route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
-- '()' ==> 204 No Content -- '()' ==> 204 No Content
instance instance
@ -271,7 +274,7 @@ instance
type ServerT (Get ctypes ()) m = m () type ServerT (Get ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodGet route Proxy _ = methodRouterEmpty methodGet
-- Add response headers -- Add response headers
instance instance
@ -283,7 +286,7 @@ instance
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
-- | If you use 'Header' in one of the endpoints for your API, -- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -311,9 +314,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (Header sym a :> sublayout) m = type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver = WithRequest $ \ request -> route Proxy cfg subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) in route (Proxy :: Proxy sublayout) cfg (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym) where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | When implementing the handler for a 'Post' endpoint, -- | When implementing the handler for a 'Post' endpoint,
@ -338,7 +341,7 @@ instance
type ServerT (Post ctypes a) m = m a type ServerT (Post ctypes a) m = m a
route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 route Proxy _ = methodRouter methodPost (Proxy :: Proxy ctypes) created201
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -348,7 +351,7 @@ instance
type ServerT (Post ctypes ()) m = m () type ServerT (Post ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPost route Proxy _ = methodRouterEmpty methodPost
-- Add response headers -- Add response headers
instance instance
@ -360,7 +363,7 @@ instance
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 route Proxy _ = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
-- | When implementing the handler for a 'Put' endpoint, -- | When implementing the handler for a 'Put' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@ -383,7 +386,7 @@ instance
type ServerT (Put ctypes a) m = m a type ServerT (Put ctypes a) m = m a
route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -393,7 +396,7 @@ instance
type ServerT (Put ctypes ()) m = m () type ServerT (Put ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPut route Proxy _ = methodRouterEmpty methodPut
-- Add response headers -- Add response headers
instance instance
@ -405,7 +408,7 @@ instance
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
-- | When implementing the handler for a 'Patch' endpoint, -- | When implementing the handler for a 'Patch' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@ -426,7 +429,7 @@ instance
type ServerT (Patch ctypes a) m = m a type ServerT (Patch ctypes a) m = m a
route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -436,7 +439,7 @@ instance
type ServerT (Patch ctypes ()) m = m () type ServerT (Patch ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPatch route Proxy _ = methodRouterEmpty methodPatch
-- Add response headers -- Add response headers
instance instance
@ -448,7 +451,7 @@ instance
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 route Proxy _ = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -477,7 +480,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParam sym a :> sublayout) m = type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver = WithRequest $ \ request -> route Proxy cfg subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
param = param =
case lookup paramname querytext of case lookup paramname querytext of
@ -485,7 +488,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
Just Nothing -> Nothing -- param present with no value -> Nothing Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
-- the right type -- the right type
in route (Proxy :: Proxy sublayout) (passToServer subserver param) in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@ -513,14 +516,14 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParams sym a :> sublayout) m = type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT sublayout m
route Proxy subserver = WithRequest $ \ request -> route Proxy cfg subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
-- if sym is "foo", we look for query string parameters -- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call parseQueryParam on the -- named "foo" or "foo[]" and call parseQueryParam on the
-- corresponding values -- corresponding values
parameters = filter looksLikeParam querytext parameters = filter looksLikeParam querytext
values = mapMaybe (convert . snd) parameters values = mapMaybe (convert . snd) parameters
in route (Proxy :: Proxy sublayout) (passToServer subserver values) in route (Proxy :: Proxy sublayout) cfg (passToServer subserver values)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing convert Nothing = Nothing
@ -544,13 +547,13 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (QueryFlag sym :> sublayout) m = type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT sublayout m
route Proxy subserver = WithRequest $ \ request -> route Proxy cfg subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext of param = case lookup paramname querytext of
Just Nothing -> True -- param is there, with no value Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string Nothing -> False -- param not in the query string
in route (Proxy :: Proxy sublayout) (passToServer subserver param) in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False | otherwise = False
@ -567,7 +570,7 @@ instance HasServer Raw where
type ServerT Raw m = Application type ServerT Raw m = Application
route Proxy rawApplication = LeafRouter $ \ request respond -> do route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication r <- runDelayed rawApplication
case r of case r of
Route app -> app request (respond . Route) Route app -> app request (respond . Route)
@ -601,8 +604,8 @@ instance ( AllCTUnrender list a, HasServer sublayout
type ServerT (ReqBody list a :> sublayout) m = type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver = WithRequest $ \ request -> route Proxy cfg subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request)) route (Proxy :: Proxy sublayout) cfg (addBodyCheck subserver (bodyCheck request))
where where
bodyCheck request = do bodyCheck request = do
-- See HTTP RFC 2616, section 7.2.1 -- See HTTP RFC 2616, section 7.2.1
@ -624,36 +627,36 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
type ServerT (path :> sublayout) m = ServerT sublayout m type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver = StaticRouter $ route Proxy cfg subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath)) M.singleton (cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) subserver) (route (Proxy :: Proxy sublayout) cfg subserver)
where proxyPath = Proxy :: Proxy path where proxyPath = Proxy :: Proxy path
instance HasServer api => HasServer (RemoteHost :> api) where instance HasServer api => HasServer (RemoteHost :> api) where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy subserver = WithRequest $ \req -> route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req) route (Proxy :: Proxy api) cfg (passToServer subserver $ remoteHost req)
instance HasServer api => HasServer (IsSecure :> api) where instance HasServer api => HasServer (IsSecure :> api) where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy subserver = WithRequest $ \req -> route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ secure req) route (Proxy :: Proxy api) cfg (passToServer subserver $ secure req)
where secure req = if isSecure req then Secure else NotSecure where secure req = if isSecure req then Secure else NotSecure
instance HasServer api => HasServer (Vault :> api) where instance HasServer api => HasServer (Vault :> api) where
type ServerT (Vault :> api) m = Vault -> ServerT api m type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy subserver = WithRequest $ \req -> route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ vault req) route (Proxy :: Proxy api) cfg (passToServer subserver $ vault req)
instance HasServer api => HasServer (HttpVersion :> api) where instance HasServer api => HasServer (HttpVersion :> api) where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy subserver = WithRequest $ \req -> route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req) route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req)
pathIsEmpty :: Request -> Bool pathIsEmpty :: Request -> Bool
pathIsEmpty = go . pathInfo pathIsEmpty = go . pathInfo

62
servant-server/src/Servant/Server/Internal/Config.hs Normal file
View file

@ -0,0 +1,62 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
module Servant.Server.Internal.Config where
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
-- | A single entry in the configuration. The first parameter is phantom, and
-- is used to lookup a @ConfigEntry@ in a @Config@.
newtype ConfigEntry tag a = ConfigEntry { unConfigEntry :: a }
deriving ( Eq, Show, Read, Enum, Integral, Fractional, Generic, Typeable
, Num, Ord, Real, Functor, Foldable, Traversable)
instance Applicative (ConfigEntry tag) where
pure = ConfigEntry
ConfigEntry f <*> ConfigEntry a = ConfigEntry $ f a
instance Monad (ConfigEntry tag) where
return = ConfigEntry
ConfigEntry a >>= f = f a
-- | The entire configuration.
data Config a where
EmptyConfig :: Config '[]
ConsConfig :: x -> Config xs -> Config (x ': xs)
(.:) :: x -> Config xs -> Config (ConfigEntry tag x ': xs)
e .: cfg = ConsConfig (ConfigEntry e) cfg
infixr 4 .:
class HasConfigEntry (cfg :: [*]) a val | cfg a -> val where
getConfigEntry :: proxy a -> Config cfg -> val
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where
getConfigEntry p (ConsConfig _ xs) = getConfigEntry p xs
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
HasConfigEntry (ConfigEntry tag val ': xs) tag val where
getConfigEntry _ (ConsConfig x _) = unConfigEntry x

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

@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402
errorOrderSpec :: Spec errorOrderSpec :: Spec
errorOrderSpec = describe "HTTP error order" errorOrderSpec = describe "HTTP error order"
$ with (return $ serve errorOrderApi errorOrderServer) $ do $ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do
let badContentType = (hContentType, "text/plain") let badContentType = (hContentType, "text/plain")
badAccept = (hAccept, "text/plain") badAccept = (hAccept, "text/plain")
badMethod = methodGet badMethod = methodGet
@ -89,7 +89,7 @@ prioErrorsApi = Proxy
prioErrorsSpec :: Spec prioErrorsSpec :: Spec
prioErrorsSpec = describe "PrioErrors" $ do prioErrorsSpec = describe "PrioErrors" $ do
let server = return let server = return
with (return $ serve prioErrorsApi server) $ do with (return $ serve prioErrorsApi EmptyConfig server) $ do
let check (mdescr, method) path (cdescr, ctype, body) resp = let check (mdescr, method) path (cdescr, ctype, body) resp =
it fulldescr $ it fulldescr $
Test.Hspec.Wai.request method path [(hContentType, ctype)] body Test.Hspec.Wai.request method path [(hContentType, ctype)] body
@ -154,7 +154,7 @@ errorRetryServer
errorRetrySpec :: Spec errorRetrySpec :: Spec
errorRetrySpec = describe "Handler search" errorRetrySpec = describe "Handler search"
$ with (return $ serve errorRetryApi errorRetryServer) $ do $ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do
let jsonCT = (hContentType, "application/json") let jsonCT = (hContentType, "application/json")
jsonAccept = (hAccept, "application/json") jsonAccept = (hAccept, "application/json")
@ -194,7 +194,7 @@ errorChoiceServer = return 0
errorChoiceSpec :: Spec errorChoiceSpec :: Spec
errorChoiceSpec = describe "Multiple handlers return errors" errorChoiceSpec = describe "Multiple handlers return errors"
$ with (return $ serve errorChoiceApi errorChoiceServer) $ do $ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do
it "should respond with 404 if no path matches" $ do it "should respond with 404 if no path matches" $ do
request methodGet "" [] "" `shouldRespondWith` 404 request methodGet "" [] "" `shouldRespondWith` 404

4
servant-server/test/Servant/Server/Internal/EnterSpec.hs
View file

@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer'
enterSpec :: Spec enterSpec :: Spec
enterSpec = describe "Enter" $ do enterSpec = describe "Enter" $ do
with (return (serve readerAPI readerServer)) $ do with (return (serve readerAPI EmptyConfig readerServer)) $ do
it "allows running arbitrary monads" $ do it "allows running arbitrary monads" $ do
get "int" `shouldRespondWith` "1797" get "int" `shouldRespondWith` "1797"
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
with (return (serve combinedAPI combinedReaderServer)) $ do with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do
it "allows combnation of enters" $ do it "allows combnation of enters" $ do
get "bool" `shouldRespondWith` "true" get "bool" `shouldRespondWith` "true"

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

@ -23,14 +23,15 @@ import Data.String (fromString)
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Types (hAccept, hContentType, import Network.HTTP.Types (Status (..), hAccept, hContentType,
methodDelete, methodGet, methodHead, methodDelete, methodGet,
methodPatch, methodPost, methodPut, methodHead, methodPatch,
ok200, parseQuery, Status(..)) methodPost, methodPut, ok200,
parseQuery)
import Network.Wai (Application, Request, pathInfo, import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString, queryString, rawQueryString,
responseLBS, responseBuilder) responseBuilder, responseLBS)
import Network.Wai.Internal (Response(ResponseBuilder)) import Network.Wai.Internal (Response (ResponseBuilder))
import Network.Wai.Test (defaultRequest, request, import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody) runSession, simpleBody)
import Servant.API ((:<|>) (..), (:>), Capture, Delete, import Servant.API ((:<|>) (..), (:>), Capture, Delete,
@ -40,15 +41,20 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
QueryFlag, QueryParam, QueryParams, QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Raw, RemoteHost, ReqBody,
addHeader) addHeader)
import Servant.Server (Server, serve, ServantErr(..), err404)
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai (get, liftIO, matchHeaders, import Test.Hspec.Wai (get, liftIO, matchHeaders,
matchStatus, post, request, matchStatus, post, request,
shouldRespondWith, with, (<:>)) shouldRespondWith, with, (<:>))
import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))
import Servant.Server.Internal.Router import Servant.Server (Config(EmptyConfig),
(tweakResponse, runRouter, ServantErr (..),
Router, Router'(LeafRouter)) Server, err404,
serve)
import Servant.Server.Internal.Router (Router, Router' (LeafRouter),
runRouter,
tweakResponse)
import Servant.Server.Internal.RoutingApplication (RouteResult (..),
toApplication)
-- * test data types -- * test data types
@ -112,7 +118,7 @@ captureServer legs = case legs of
captureSpec :: Spec captureSpec :: Spec
captureSpec = do captureSpec = do
describe "Servant.API.Capture" $ do describe "Servant.API.Capture" $ do
with (return (serve captureApi captureServer)) $ do with (return (serve captureApi EmptyConfig captureServer)) $ do
it "can capture parts of the 'pathInfo'" $ do it "can capture parts of the 'pathInfo'" $ do
response <- get "/2" response <- get "/2"
@ -123,6 +129,7 @@ captureSpec = do
with (return (serve with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw)) (Proxy :: Proxy (Capture "captured" String :> Raw))
EmptyConfig
(\ "captured" request_ respond -> (\ "captured" request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
it "strips the captured path snippet from pathInfo" $ do it "strips the captured path snippet from pathInfo" $ do
@ -139,7 +146,7 @@ getSpec :: Spec
getSpec = do getSpec = do
describe "Servant.API.Get" $ do describe "Servant.API.Get" $ do
let server = return alice :<|> return () :<|> return () let server = return alice :<|> return () :<|> return ()
with (return $ serve getApi server) $ do with (return $ serve getApi EmptyConfig server) $ do
it "allows to GET a Person" $ do it "allows to GET a Person" $ do
response <- get "/" response <- get "/"
@ -162,7 +169,7 @@ headSpec :: Spec
headSpec = do headSpec = do
describe "Servant.API.Head" $ do describe "Servant.API.Head" $ do
let server = return alice :<|> return () :<|> return () let server = return alice :<|> return () :<|> return ()
with (return $ serve getApi server) $ do with (return $ serve getApi EmptyConfig server) $ do
it "allows to GET a Person" $ do it "allows to GET a Person" $ do
response <- Test.Hspec.Wai.request methodHead "/" [] "" response <- Test.Hspec.Wai.request methodHead "/" [] ""
@ -209,7 +216,7 @@ queryParamSpec :: Spec
queryParamSpec = do queryParamSpec = do
describe "Servant.API.QueryParam" $ do describe "Servant.API.QueryParam" $ do
it "allows to retrieve simple GET parameters" $ it "allows to retrieve simple GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params1 = "?name=bob" let params1 = "?name=bob"
response1 <- Network.Wai.Test.request defaultRequest{ response1 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params1, rawQueryString = params1,
@ -221,7 +228,7 @@ queryParamSpec = do
} }
it "allows to retrieve lists in GET parameters" $ it "allows to retrieve lists in GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params2 = "?names[]=bob&names[]=john" let params2 = "?names[]=bob&names[]=john"
response2 <- Network.Wai.Test.request defaultRequest{ response2 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params2, rawQueryString = params2,
@ -235,7 +242,7 @@ queryParamSpec = do
it "allows to retrieve value-less GET parameters" $ it "allows to retrieve value-less GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params3 = "?capitalize" let params3 = "?capitalize"
response3 <- Network.Wai.Test.request defaultRequest{ response3 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3, rawQueryString = params3,
@ -281,7 +288,7 @@ postSpec :: Spec
postSpec = do postSpec = do
describe "Servant.API.Post and .ReqBody" $ do describe "Servant.API.Post and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return () let server = return . age :<|> return . age :<|> return ()
with (return $ serve postApi server) $ do with (return $ serve postApi EmptyConfig server) $ do
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/json;charset=utf-8")] , "application/json;charset=utf-8")]
@ -323,7 +330,7 @@ putSpec :: Spec
putSpec = do putSpec = do
describe "Servant.API.Put and .ReqBody" $ do describe "Servant.API.Put and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return () let server = return . age :<|> return . age :<|> return ()
with (return $ serve putApi server) $ do with (return $ serve putApi EmptyConfig server) $ do
let put' x = Test.Hspec.Wai.request methodPut x [(hContentType let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/json;charset=utf-8")] , "application/json;charset=utf-8")]
@ -365,7 +372,7 @@ patchSpec :: Spec
patchSpec = do patchSpec = do
describe "Servant.API.Patch and .ReqBody" $ do describe "Servant.API.Patch and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return () let server = return . age :<|> return . age :<|> return ()
with (return $ serve patchApi server) $ do with (return $ serve patchApi EmptyConfig server) $ do
let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/json;charset=utf-8")] , "application/json;charset=utf-8")]
@ -410,13 +417,13 @@ headerSpec = describe "Servant.API.Header" $ do
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string" expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do with (return (serve headerApi EmptyConfig expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")] let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
it "passes the header to the handler (Int)" $ it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 204 delete' "/" "" `shouldRespondWith` 204
with (return (serve headerApi expectsString)) $ do with (return (serve headerApi EmptyConfig expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")] let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
it "passes the header to the handler (String)" $ it "passes the header to the handler (String)" $
@ -433,7 +440,7 @@ rawSpec :: Spec
rawSpec = do rawSpec = do
describe "Servant.API.Raw" $ do describe "Servant.API.Raw" $ do
it "runs applications" $ do it "runs applications" $ do
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do
response <- Network.Wai.Test.request defaultRequest{ response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"] pathInfo = ["foo"]
} }
@ -441,7 +448,7 @@ rawSpec = do
simpleBody response `shouldBe` "42" simpleBody response `shouldBe` "42"
it "gets the pathInfo modified" $ do it "gets the pathInfo modified" $ do
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do
response <- Network.Wai.Test.request defaultRequest{ response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"] pathInfo = ["foo", "bar"]
} }
@ -471,7 +478,7 @@ unionServer =
unionSpec :: Spec unionSpec :: Spec
unionSpec = do unionSpec = do
describe "Servant.API.Alternative" $ do describe "Servant.API.Alternative" $ do
with (return $ serve unionApi unionServer) $ do with (return $ serve unionApi EmptyConfig unionServer) $ do
it "unions endpoints" $ do it "unions endpoints" $ do
response <- get "/foo" response <- get "/foo"
@ -503,7 +510,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
responseHeadersSpec :: Spec responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do
let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
@ -562,7 +569,7 @@ miscServ = versionHandler
hostHandler = return . show hostHandler = return . show
miscReqCombinatorsSpec :: Spec miscReqCombinatorsSpec :: Spec
miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ miscReqCombinatorsSpec = with (return $ serve miscApi EmptyConfig miscServ) $
describe "Misc. combinators for request inspection" $ do describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $ it "Successfully gets the HTTP version specified in the request" $
go "/version" "\"HTTP/1.0\"" go "/version" "\"HTTP/1.0\""

4
servant-server/test/Servant/Utils/StaticFilesSpec.hs
View file

@ -21,7 +21,7 @@ import Servant.API.Capture (Capture)
import Servant.API.Get (Get) import Servant.API.Get (Get)
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.API.Sub ((:>)) import Servant.API.Sub ((:>))
import Servant.Server (Server, serve) import Servant.Server (Server, serve, Config(EmptyConfig))
import Servant.ServerSpec (Person (Person)) import Servant.ServerSpec (Person (Person))
import Servant.Utils.StaticFiles (serveDirectory) import Servant.Utils.StaticFiles (serveDirectory)
@ -34,7 +34,7 @@ api :: Proxy Api
api = Proxy api = Proxy
app :: Application app :: Application
app = serve api server app = serve api EmptyConfig server
server :: Server Api server :: Server Api
server = server =