Add Config parameter.
This allows combinator instances to receive dynamic data that isn't constrained by the interface of Delayed etc.
This commit is contained in:
parent
034a687c3f
commit
212f066736
9 changed files with 149 additions and 68 deletions
|
@ -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.
|
||||||
--
|
--
|
||||||
|
|
|
@ -37,6 +37,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
|
||||||
|
|
|
@ -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 ())
|
||||||
|
|
|
@ -13,6 +13,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
|
||||||
|
@ -58,6 +59,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
|
||||||
|
@ -66,7 +68,7 @@ import Servant.Server.Internal.ServantErr
|
||||||
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)
|
||||||
|
|
||||||
|
@ -87,8 +89,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
|
||||||
|
|
||||||
|
@ -118,9 +120,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
|
||||||
|
@ -193,7 +196,7 @@ instance OVERLAPPABLE_
|
||||||
|
|
||||||
type ServerT (Verb method status ctypes a) m = m a
|
type ServerT (Verb method status ctypes a) m = m a
|
||||||
|
|
||||||
route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
|
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
||||||
|
|
||||||
|
@ -204,7 +207,7 @@ instance OVERLAPPING_
|
||||||
|
|
||||||
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
|
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
|
||||||
|
|
||||||
route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
|
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
||||||
|
|
||||||
|
@ -234,9 +237,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)
|
||||||
|
|
||||||
-- | 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,
|
||||||
|
@ -266,7 +269,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
|
||||||
|
@ -274,7 +277,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,
|
||||||
|
@ -302,14 +305,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
|
||||||
|
@ -333,13 +336,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
|
||||||
|
@ -356,7 +359,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)
|
||||||
|
@ -390,8 +393,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
|
||||||
|
@ -413,36 +416,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
62
servant-server/src/Servant/Server/Internal/Config.hs
Normal 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
|
|
@ -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
|
||||||
|
|
|
@ -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 = 200 }
|
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
|
||||||
|
|
||||||
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"
|
||||||
|
|
|
@ -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
|
||||||
|
@ -145,7 +152,7 @@ getSpec = do
|
||||||
:<|> return (addHeader 5 ())
|
:<|> return (addHeader 5 ())
|
||||||
:<|> 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 "/"
|
||||||
|
@ -171,7 +178,7 @@ headSpec = do
|
||||||
:<|> return ()
|
:<|> return ()
|
||||||
:<|> return (addHeader 5 ())
|
:<|> return (addHeader 5 ())
|
||||||
:<|> 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 "/" [] ""
|
||||||
|
@ -214,7 +221,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,
|
||||||
|
@ -226,7 +233,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,
|
||||||
|
@ -240,7 +247,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,
|
||||||
|
@ -286,7 +293,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")]
|
||||||
|
|
||||||
|
@ -325,7 +332,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")]
|
||||||
|
|
||||||
|
@ -364,7 +371,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")]
|
||||||
|
|
||||||
|
@ -406,14 +413,14 @@ 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` 200
|
delete' "/" "" `shouldRespondWith` 200
|
||||||
|
|
||||||
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)" $
|
||||||
delete' "/" "" `shouldRespondWith` 200
|
delete' "/" "" `shouldRespondWith` 200
|
||||||
|
@ -429,7 +436,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"]
|
||||||
}
|
}
|
||||||
|
@ -437,7 +444,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"]
|
||||||
}
|
}
|
||||||
|
@ -467,7 +474,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"
|
||||||
|
@ -499,7 +506,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, 200), (methodPut, 200), (methodPatch, 200)]
|
let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)]
|
||||||
|
|
||||||
|
@ -558,7 +565,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\""
|
||||||
|
|
|
@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it)
|
||||||
import Test.Hspec.Wai (get, shouldRespondWith, with)
|
import Test.Hspec.Wai (get, shouldRespondWith, with)
|
||||||
|
|
||||||
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
|
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
|
||||||
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)
|
||||||
|
|
||||||
|
@ -29,7 +29,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 =
|
||||||
|
|
Loading…
Reference in a new issue