renaming: Config -> Context

This commit is contained in:
Sönke Hahn 2016-02-28 23:23:32 +01:00
parent 65d0a51d60
commit 8ef4d4543b
24 changed files with 509 additions and 510 deletions

View file

@ -418,9 +418,9 @@ instance HasClient api => HasClient (IsSecure :> api) where
clientWithRoute (Proxy :: Proxy api) req baseurl manager
instance HasClient subapi =>
HasClient (WithNamedConfig name config subapi) where
HasClient (WithNamedContext name context subapi) where
type Client (WithNamedConfig name config subapi) = Client subapi
type Client (WithNamedContext name context subapi) = Client subapi
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

View file

@ -794,7 +794,7 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (WithNamedConfig name config sublayout) where
instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where
docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
-- ToSample instances for simple types

View file

@ -35,18 +35,18 @@ isGoodCookie ref password = do
data AuthProtected
instance (HasConfigEntry config DBConnection, HasServer rest config)
=> HasServer (AuthProtected :> rest) config where
instance (HasContextEntry context DBConnection, HasServer rest context)
=> HasServer (AuthProtected :> rest) context where
type ServerT (AuthProtected :> rest) m = ServerT rest m
route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request
route Proxy context subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request
where
cookieCheck req = case lookup "Cookie" (requestHeaders req) of
Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
Just v -> do
let dbConnection = getConfigEntry config
let dbConnection = getContextEntry context
authGranted <- isGoodCookie dbConnection v
if authGranted
then return $ Route ()
@ -81,8 +81,8 @@ server = return prvdata :<|> return pubdata
main :: IO ()
main = do
dbConnection <- initDB
let config = dbConnection :. EmptyConfig
run 8080 (serveWithConfig api config server)
let context = dbConnection :. EmptyContext
run 8080 (serveWithContext api context server)
{- Sample session:
$ curl http://localhost:8080/

View file

@ -41,7 +41,7 @@ server = return products
-- logStdout :: Middleware
-- i.e, logStdout :: Application -> Application
-- serve :: Proxy api -> Config config -> Server api -> Application
-- serve :: Proxy api -> Context context -> Server api -> Application
-- so applying a middleware is really as simple as
-- applying a function to the result of 'serve'
app :: Application

View file

@ -310,9 +310,9 @@ instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where
foreignFor lang (Proxy :: Proxy sublayout) req
instance HasForeign lang sublayout =>
HasForeign lang (WithNamedConfig name config sublayout) where
HasForeign lang (WithNamedContext name context sublayout) where
type Foreign (WithNamedConfig name config sublayout) = Foreign sublayout
type Foreign (WithNamedContext name context sublayout) = Foreign sublayout
foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout)

View file

@ -74,7 +74,7 @@ import Test.QuickCheck.Gen (Gen, generate)
-- than turns them into random-response-generating
-- request handlers, hence providing an instance for
-- all the combinators of the core /servant/ library.
class HasServer api config => HasMock api config where
class HasServer api context => HasMock api context where
-- | Calling this method creates request handlers of
-- the right type to implement the API described by
-- @api@ that just generate random response values of
@ -104,67 +104,67 @@ class HasServer api config => HasMock api config where
-- So under the hood, 'mock' uses the 'IO' bit to generate
-- random values of type 'User' and 'Book' every time these
-- endpoints are requested.
mock :: Proxy api -> Proxy config -> Server api
mock :: Proxy api -> Proxy context -> Server api
instance (HasMock a config, HasMock b config) => HasMock (a :<|> b) config where
mock _ config = mock (Proxy :: Proxy a) config :<|> mock (Proxy :: Proxy b) config
instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where
mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context
instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where
instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where
mock _ = mock (Proxy :: Proxy rest)
instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) => HasMock (Capture s a :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest config => HasMock (RemoteHost :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest context => HasMock (RemoteHost :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest config => HasMock (IsSecure :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest context => HasMock (IsSecure :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest config => HasMock (Vault :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest context => HasMock (Vault :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest config => HasMock (HttpVersion :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest context => HasMock (HttpVersion :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)
=> HasMock (QueryParam s a :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)
=> HasMock (QueryParam s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)
=> HasMock (QueryParams s a :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)
=> HasMock (QueryParams s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where
mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes a) config where
=> HasMock (Verb method status ctypes a) context where
mock _ _ = mockArbitrary
instance OVERLAPPING_
(GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),
Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes (Headers headerTypes a)) config where
=> HasMock (Verb method status ctypes (Headers headerTypes a)) context where
mock _ _ = mockArbitrary
instance HasMock Raw config where
instance HasMock Raw context where
mock _ _ = \_req respond -> do
bdy <- genBody
respond $ responseLBS status200 [] bdy
where genBody = pack <$> generate (vector 100 :: Gen [Char])
instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) =>
HasMock (WithNamedConfig name subConfig rest) config where
instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) =>
HasMock (WithNamedContext name subContext rest) context where
mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig)
mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext)
mockArbitrary :: (MonadIO m, Arbitrary a) => m a
mockArbitrary = liftIO (generate arbitrary)

View file

@ -23,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Mock
-- This declaration simply checks that all instances are in place.
_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]])
_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]])
data Body
= Body

View file

@ -37,7 +37,7 @@ library
Servant
Servant.Server
Servant.Server.Internal
Servant.Server.Internal.Config
Servant.Server.Internal.Context
Servant.Server.Internal.Enter
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
@ -96,11 +96,11 @@ test-suite spec
main-is: Spec.hs
other-modules:
Servant.Server.ErrorSpec
Servant.Server.Internal.ConfigSpec
Servant.Server.Internal.ContextSpec
Servant.Server.Internal.EnterSpec
Servant.ServerSpec
Servant.Server.UsingConfigSpec
Servant.Server.UsingConfigSpec.TestCombinators
Servant.Server.UsingContextSpec
Servant.Server.UsingContextSpec.TestCombinators
Servant.Utils.StaticFilesSpec
build-depends:
base == 4.*

View file

@ -9,7 +9,7 @@
module Servant.Server
( -- * Run a wai application from an API
serve
, serveWithConfig
, serveWithContext
, -- * Construct a wai Application from an API
toApplication
@ -38,12 +38,12 @@ module Servant.Server
, generalizeNat
, tweakResponse
-- * Config
, Config(..)
, HasConfigEntry(getConfigEntry)
-- ** NamedConfig
, NamedConfig(..)
, descendIntoNamedConfig
-- * Context
, Context(..)
, HasContextEntry(getContextEntry)
-- ** NamedContext
, NamedContext(..)
, descendIntoNamedContext
-- * Default error type
, ServantErr(..)
@ -113,11 +113,11 @@ import Servant.Server.Internal.Enter
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application
serve p = serveWithConfig p EmptyConfig
serve p = serveWithContext p EmptyContext
serveWithConfig :: (HasServer layout config)
=> Proxy layout -> Config config -> Server layout -> Application
serveWithConfig p config server = toApplication (runRouter (route p config d))
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)
r = return (Route ())

View file

@ -15,7 +15,7 @@
module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.Config
, module Servant.Server.Internal.Context
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr
@ -53,7 +53,7 @@ import Servant.API ((:<|>) (..), (:>), Capture,
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault,
WithNamedConfig)
WithNamedContext)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
@ -62,16 +62,16 @@ import Servant.API.ContentTypes (AcceptHeader (..),
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
getResponse)
import Servant.Server.Internal.Config
import Servant.Server.Internal.Context
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
class HasServer layout config where
class HasServer layout context where
type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Config config -> Delayed (Server layout) -> Router
route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router
type Server layout = ServerT layout (ExceptT ServantErr IO)
@ -88,12 +88,12 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)
-- > server = listAllBooks :<|> postBook
-- > where listAllBooks = ...
-- > postBook book = ...
instance (HasServer a config, HasServer b config) => HasServer (a :<|> b) config where
instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
(route pb config ((\ (_ :<|> b) -> b) <$> server))
route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))
(route pb context ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
@ -117,16 +117,16 @@ captured _ = parseUrlPieceMaybe
-- > server = getBook
-- > where getBook :: Text -> ExceptT ServantErr IO Book
-- > getBook isbn = ...
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config)
=> HasServer (Capture capture a :> sublayout) config where
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
=> HasServer (Capture capture a :> sublayout) context where
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
route Proxy config d =
route Proxy context d =
DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout)
config
context
(addCapture d $ case captured captureProxy first of
Nothing -> return $ Fail err404
Just v -> return $ Route v
@ -195,7 +195,7 @@ methodRouterHeaders method proxy status action = LeafRouter route'
instance OVERLAPPABLE_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
) => HasServer (Verb method status ctypes a) config where
) => HasServer (Verb method status ctypes a) context where
type ServerT (Verb method status ctypes a) m = m a
@ -206,7 +206,7 @@ instance OVERLAPPABLE_
instance OVERLAPPING_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) config where
) => HasServer (Verb method status ctypes (Headers h a)) context where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
@ -234,15 +234,15 @@ instance OVERLAPPING_
-- > server = viewReferer
-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer
-- > viewReferer referer = return referer
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
=> HasServer (Header sym a :> sublayout) config where
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (Header sym a :> sublayout) context where
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy config subserver = WithRequest $ \ request ->
route Proxy context subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader)
in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
@ -266,13 +266,13 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]
-- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
=> HasServer (QueryParam sym a :> sublayout) config where
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (QueryParam sym a :> sublayout) context where
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy config subserver = WithRequest $ \ request ->
route Proxy context subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramname querytext of
@ -280,7 +280,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
-- the right type
in route (Proxy :: Proxy sublayout) config (passToServer subserver param)
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@ -302,20 +302,20 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
-- > server = getBooksBy
-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]
-- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
=> HasServer (QueryParams sym a :> sublayout) config where
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (QueryParams sym a :> sublayout) context where
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy config subserver = WithRequest $ \ request ->
route Proxy context subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
-- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call parseQueryParam on the
-- corresponding values
parameters = filter looksLikeParam querytext
values = mapMaybe (convert . snd) parameters
in route (Proxy :: Proxy sublayout) config (passToServer subserver values)
in route (Proxy :: Proxy sublayout) context (passToServer subserver values)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
@ -333,19 +333,19 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
-- > server = getBooks
-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout config)
=> HasServer (QueryFlag sym :> sublayout) config where
instance (KnownSymbol sym, HasServer sublayout context)
=> HasServer (QueryFlag sym :> sublayout) context where
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy config subserver = WithRequest $ \ request ->
route Proxy context subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext of
Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string
in route (Proxy :: Proxy sublayout) config (passToServer subserver param)
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
@ -358,7 +358,7 @@ instance (KnownSymbol sym, HasServer sublayout config)
-- >
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw config where
instance HasServer Raw context where
type ServerT Raw m = Application
@ -390,14 +390,14 @@ instance HasServer Raw config where
-- > server = postBook
-- > where postBook :: Book -> ExceptT ServantErr IO Book
-- > postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer sublayout config
) => HasServer (ReqBody list a :> sublayout) config where
instance ( AllCTUnrender list a, HasServer sublayout context
) => HasServer (ReqBody list a :> sublayout) context where
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))
route Proxy context subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))
where
bodyCheck request = do
-- See HTTP RFC 2616, section 7.2.1
@ -415,40 +415,40 @@ instance ( AllCTUnrender list a, HasServer sublayout config
-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout config) => HasServer (path :> sublayout) config where
instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where
type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy config subserver = StaticRouter $
route Proxy context subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) config subserver)
(route (Proxy :: Proxy sublayout) context subserver)
where proxyPath = Proxy :: Proxy path
instance HasServer api config => HasServer (RemoteHost :> api) config where
instance HasServer api context => HasServer (RemoteHost :> api) context where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)
instance HasServer api config => HasServer (IsSecure :> api) config where
instance HasServer api context => HasServer (IsSecure :> api) context where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ secure req)
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ secure req)
where secure req = if isSecure req then Secure else NotSecure
instance HasServer api config => HasServer (Vault :> api) config where
instance HasServer api context => HasServer (Vault :> api) context where
type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ vault req)
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ vault req)
instance HasServer api config => HasServer (HttpVersion :> api) config where
instance HasServer api context => HasServer (HttpVersion :> api) context where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
pathIsEmpty :: Request -> Bool
pathIsEmpty = go . pathInfo
@ -459,19 +459,19 @@ pathIsEmpty = go . pathInfo
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
-- * configs
-- * contexts
instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig)
=> HasServer (WithNamedConfig name subConfig subApi) config where
instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)
=> HasServer (WithNamedContext name subContext subApi) context where
type ServerT (WithNamedConfig name subConfig subApi) m =
type ServerT (WithNamedContext name subContext subApi) m =
ServerT subApi m
route Proxy config delayed =
route subProxy subConfig delayed
route Proxy context delayed =
route subProxy subContext delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
subConfig :: Config subConfig
subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config
subContext :: Context subContext
subContext = descendIntoNamedContext (Proxy :: Proxy name) context

View file

@ -1,99 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
#include "overlapping-compat.h"
module Servant.Server.Internal.Config where
import Data.Proxy
import GHC.TypeLits
-- | When calling 'Servant.Server.serve' you have to supply a configuration
-- value of type @'Config' configTypes@. This parameter is used to pass values
-- to combinators. (It shouldn't be confused with general configuration
-- parameters for your web app, like the port, etc.). If you don't use
-- combinators that require any config entries, you can just pass 'EmptyConfig'.
-- To create a config with entries, use the operator @(':.')@. The parameter of
-- the type 'Config' is a type-level list reflecting the types of the contained
-- config entries:
--
-- >>> :type True :. () :. EmptyConfig
-- True :. () :. EmptyConfig :: Config '[Bool, ()]
data Config configTypes where
EmptyConfig :: Config '[]
(:.) :: x -> Config xs -> Config (x ': xs)
infixr 5 :.
instance Show (Config '[]) where
show EmptyConfig = "EmptyConfig"
instance (Show a, Show (Config as)) => Show (Config (a ': as)) where
showsPrec outerPrecedence (a :. as) =
showParen (outerPrecedence > 5) $
shows a . showString " :. " . shows as
instance Eq (Config '[]) where
_ == _ = True
instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
-- | This class is used to access config entries in 'Config's. 'getConfigEntry'
-- returns the first value where the type matches:
--
-- >>> getConfigEntry (True :. False :. EmptyConfig) :: Bool
-- True
--
-- If the 'Config' does not contain an entry of the requested type, you'll get
-- an error:
--
-- >>> getConfigEntry (True :. False :. EmptyConfig) :: String
-- ...
-- No instance for (HasConfigEntry '[] [Char])
-- ...
class HasConfigEntry (config :: [*]) (val :: *) where
getConfigEntry :: Config config -> val
instance OVERLAPPABLE_
HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
getConfigEntry (_ :. xs) = getConfigEntry xs
instance OVERLAPPING_
HasConfigEntry (val ': xs) val where
getConfigEntry (x :. _) = x
-- * support for named subconfigs
-- | Normally config entries are accessed by their types. In case you need
-- to have multiple values of the same type in your 'Config' and need to access
-- them, we provide 'NamedConfig'. You can think of it as sub-namespaces for
-- 'Config's.
data NamedConfig (name :: Symbol) (subConfig :: [*])
= NamedConfig (Config subConfig)
-- | 'descendIntoNamedConfig' allows you to access `NamedConfig's. Usually you
-- won't have to use it yourself but instead use a combinator like
-- 'Servant.API.WithNamedConfig.WithNamedConfig'.
--
-- This is how 'descendIntoNamedConfig' works:
--
-- >>> :set -XFlexibleContexts
-- >>> let subConfig = True :. EmptyConfig
-- >>> :type subConfig
-- subConfig :: Config '[Bool]
-- >>> let parentConfig = False :. (NamedConfig subConfig :: NamedConfig "subConfig" '[Bool]) :. EmptyConfig
-- >>> :type parentConfig
-- parentConfig :: Config '[Bool, NamedConfig "subConfig" '[Bool]]
-- >>> descendIntoNamedConfig (Proxy :: Proxy "subConfig") parentConfig :: Config '[Bool]
-- True :. EmptyConfig
descendIntoNamedConfig :: forall config name subConfig .
HasConfigEntry config (NamedConfig name subConfig) =>
Proxy (name :: Symbol) -> Config config -> Config subConfig
descendIntoNamedConfig Proxy config =
let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig
in subConfig

View file

@ -0,0 +1,99 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
#include "overlapping-compat.h"
module Servant.Server.Internal.Context where
import Data.Proxy
import GHC.TypeLits
-- | When calling 'Servant.Server.serve' you have to supply a context
-- value of type @'Context' contextTypes@. This parameter is used to pass values
-- to combinators. (It shouldn't be confused with general configuration
-- parameters for your web app, like the port, etc.). If you don't use
-- combinators that require any context entries, you can just use `serve` (or
-- pass 'EmptyContext'). To create a context with entries, use the operator
-- @(':.')@. The parameter of the type 'Context' is a type-level list reflecting
-- the types of the contained context entries:
--
-- >>> :type True :. () :. EmptyContext
-- True :. () :. EmptyContext :: Context '[Bool, ()]
data Context contextTypes where
EmptyContext :: Context '[]
(:.) :: x -> Context xs -> Context (x ': xs)
infixr 5 :.
instance Show (Context '[]) where
show EmptyContext = "EmptyContext"
instance (Show a, Show (Context as)) => Show (Context (a ': as)) where
showsPrec outerPrecedence (a :. as) =
showParen (outerPrecedence > 5) $
shows a . showString " :. " . shows as
instance Eq (Context '[]) where
_ == _ = True
instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
-- | This class is used to access context entries in 'Context's. 'getContextEntry'
-- returns the first value where the type matches:
--
-- >>> getContextEntry (True :. False :. EmptyContext) :: Bool
-- True
--
-- If the 'Context' does not contain an entry of the requested type, you'll get
-- an error:
--
-- >>> getContextEntry (True :. False :. EmptyContext) :: String
-- ...
-- No instance for (HasContextEntry '[] [Char])
-- ...
class HasContextEntry (context :: [*]) (val :: *) where
getContextEntry :: Context context -> val
instance OVERLAPPABLE_
HasContextEntry xs val => HasContextEntry (notIt ': xs) val where
getContextEntry (_ :. xs) = getContextEntry xs
instance OVERLAPPING_
HasContextEntry (val ': xs) val where
getContextEntry (x :. _) = x
-- * support for named subcontexts
-- | Normally context entries are accessed by their types. In case you need
-- to have multiple values of the same type in your 'Context' and need to access
-- them, we provide 'NamedContext'. You can think of it as sub-namespaces for
-- 'Context's.
data NamedContext (name :: Symbol) (subContext :: [*])
= NamedContext (Context subContext)
-- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you
-- won't have to use it yourself but instead use a combinator like
-- 'Servant.API.WithNamedContext.WithNamedContext'.
--
-- This is how 'descendIntoNamedContext' works:
--
-- >>> :set -XFlexibleContexts
-- >>> let subContext = True :. EmptyContext
-- >>> :type subContext
-- subContext :: Context '[Bool]
-- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext
-- >>> :type parentContext
-- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]]
-- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool]
-- True :. EmptyContext
descendIntoNamedContext :: forall context name subContext .
HasContextEntry context (NamedContext name subContext) =>
Proxy (name :: Symbol) -> Context context -> Context subContext
descendIntoNamedContext Proxy context =
let NamedContext subContext = getContextEntry context :: NamedContext name subContext
in subContext

View file

@ -1,61 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module Servant.Server.Internal.ConfigSpec (spec) where
import Data.Proxy (Proxy (..))
import Test.Hspec (Spec, describe, it, shouldBe, pending, context)
import Test.ShouldNotTypecheck (shouldNotTypecheck)
import Servant.API
import Servant.Server.Internal.Config
spec :: Spec
spec = do
describe "getConfigEntry" $ do
it "gets the config if a matching one exists" $ do
let config = 'a' :. EmptyConfig
getConfigEntry config `shouldBe` 'a'
it "gets the first matching config" $ do
let config = 'a' :. 'b' :. EmptyConfig
getConfigEntry config `shouldBe` 'a'
it "does not typecheck if type does not exist" $ do
let config = 'a' :. EmptyConfig
x = getConfigEntry config :: Bool
shouldNotTypecheck x
context "Show instance" $ do
let config = 'a' :. True :. EmptyConfig
it "has a Show instance" $ do
show config `shouldBe` "'a' :. True :. EmptyConfig"
context "bracketing" $ do
it "works" $ do
show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)"
it "works with operators" $ do
let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)
show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"
describe "descendIntoNamedConfig" $ do
let config :: Config [Char, NamedConfig "sub" '[Char]]
config =
'a' :.
(NamedConfig subConfig :: NamedConfig "sub" '[Char])
:. EmptyConfig
subConfig = 'b' :. EmptyConfig
it "allows extracting subconfigs" $ do
descendIntoNamedConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig
it "allows extracting entries from subconfigs" $ do
getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char])
`shouldBe` 'b'
it "does not typecheck if subConfig has the wrong type" $ do
let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int]
shouldNotTypecheck (show x)
it "does not typecheck if subConfig with that name doesn't exist" $ do
let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char]
shouldNotTypecheck (show x)

View file

@ -0,0 +1,61 @@
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module Servant.Server.Internal.ContextSpec (spec) where
import Data.Proxy (Proxy (..))
import Test.Hspec (Spec, describe, it, shouldBe, pending, context)
import Test.ShouldNotTypecheck (shouldNotTypecheck)
import Servant.API
import Servant.Server.Internal.Context
spec :: Spec
spec = do
describe "getContextEntry" $ do
it "gets the context if a matching one exists" $ do
let cxt = 'a' :. EmptyContext
getContextEntry cxt `shouldBe` 'a'
it "gets the first matching context" $ do
let cxt = 'a' :. 'b' :. EmptyContext
getContextEntry cxt `shouldBe` 'a'
it "does not typecheck if type does not exist" $ do
let cxt = 'a' :. EmptyContext
x = getContextEntry cxt :: Bool
shouldNotTypecheck x
context "Show instance" $ do
let cxt = 'a' :. True :. EmptyContext
it "has a Show instance" $ do
show cxt `shouldBe` "'a' :. True :. EmptyContext"
context "bracketing" $ do
it "works" $ do
show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)"
it "works with operators" $ do
let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)
show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)"
describe "descendIntoNamedContext" $ do
let cxt :: Context [Char, NamedContext "sub" '[Char]]
cxt =
'a' :.
(NamedContext subContext :: NamedContext "sub" '[Char])
:. EmptyContext
subContext = 'b' :. EmptyContext
it "allows extracting subcontexts" $ do
descendIntoNamedContext (Proxy :: Proxy "sub") cxt `shouldBe` subContext
it "allows extracting entries from subcontexts" $ do
getContextEntry (descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Char])
`shouldBe` 'b'
it "does not typecheck if subContext has the wrong type" $ do
let x = descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Int]
shouldNotTypecheck (show x)
it "does not typecheck if subContext with that name doesn't exist" $ do
let x = descendIntoNamedContext (Proxy :: Proxy "foo") cxt :: Context '[Char]
shouldNotTypecheck (show x)

View file

@ -1,125 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.UsingConfigSpec where
import Control.Monad.Trans.Except
import Network.Wai
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai
import Servant
import Servant.Server.UsingConfigSpec.TestCombinators
spec :: Spec
spec = do
spec1
spec2
spec3
spec4
-- * API
type OneEntryAPI =
ExtractFromConfig :> Get '[JSON] String
testServer :: String -> ExceptT ServantErr IO String
testServer s = return s
oneEntryApp :: Application
oneEntryApp =
serveWithConfig (Proxy :: Proxy OneEntryAPI) config testServer
where
config :: Config '[String]
config = "configEntry" :. EmptyConfig
type OneEntryTwiceAPI =
"foo" :> ExtractFromConfig :> Get '[JSON] String :<|>
"bar" :> ExtractFromConfig :> Get '[JSON] String
oneEntryTwiceApp :: Application
oneEntryTwiceApp = serveWithConfig (Proxy :: Proxy OneEntryTwiceAPI) config $
testServer :<|>
testServer
where
config :: Config '[String]
config = "configEntryTwice" :. EmptyConfig
-- * tests
spec1 :: Spec
spec1 = do
describe "accessing config entries from custom combinators" $ do
with (return oneEntryApp) $ do
it "allows retrieving a ConfigEntry" $ do
get "/" `shouldRespondWith` "\"configEntry\""
with (return oneEntryTwiceApp) $ do
it "allows retrieving the same ConfigEntry twice" $ do
get "/foo" `shouldRespondWith` "\"configEntryTwice\""
get "/bar" `shouldRespondWith` "\"configEntryTwice\""
type InjectAPI =
InjectIntoConfig :> "untagged" :> ExtractFromConfig :>
Get '[JSON] String :<|>
InjectIntoConfig :> "tagged" :> ExtractFromConfig :>
Get '[JSON] String
injectApp :: Application
injectApp = serveWithConfig (Proxy :: Proxy InjectAPI) config $
(\ s -> return s) :<|>
(\ s -> return ("tagged: " ++ s))
where
config = EmptyConfig
spec2 :: Spec
spec2 = do
with (return injectApp) $ do
describe "inserting config entries with custom combinators" $ do
it "allows to inject config entries" $ do
get "/untagged" `shouldRespondWith` "\"injected\""
it "allows to inject tagged config entries" $ do
get "/tagged" `shouldRespondWith` "\"tagged: injected\""
type WithBirdfaceAPI =
"foo" :> ExtractFromConfig :> Get '[JSON] String :<|>
NamedConfigWithBirdface "sub" '[String] :>
"bar" :> ExtractFromConfig :> Get '[JSON] String
withBirdfaceApp :: Application
withBirdfaceApp = serveWithConfig (Proxy :: Proxy WithBirdfaceAPI) config $
testServer :<|>
testServer
where
config :: Config '[String, (NamedConfig "sub" '[String])]
config =
"firstEntry" :.
(NamedConfig ("secondEntry" :. EmptyConfig)) :.
EmptyConfig
spec3 :: Spec
spec3 = do
with (return withBirdfaceApp) $ do
it "allows retrieving different ConfigEntries for the same combinator" $ do
get "/foo" `shouldRespondWith` "\"firstEntry\""
get "/bar" `shouldRespondWith` "\"secondEntry\""
type NamedConfigAPI =
WithNamedConfig "sub" '[String] (
ExtractFromConfig :> Get '[JSON] String)
namedConfigApp :: Application
namedConfigApp = serveWithConfig (Proxy :: Proxy NamedConfigAPI) config return
where
config :: Config '[NamedConfig "sub" '[String]]
config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig
spec4 :: Spec
spec4 = do
with (return namedConfigApp) $ do
describe "WithNamedConfig" $ do
it "allows descending into a subconfig for a given api" $ do
get "/" `shouldRespondWith` "\"descend\""

View file

@ -1,73 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | These are custom combinators for Servant.Server.UsingConfigSpec.
--
-- (For writing your own combinators you need to import Internal modules, for
-- just *using* combinators that require a Config, you don't. This module is
-- separate from Servant.Server.UsingConfigSpec to test that the module imports
-- work out this way.)
module Servant.Server.UsingConfigSpec.TestCombinators where
import GHC.TypeLits
import Servant
import Servant.Server.Internal.Config
import Servant.Server.Internal.RoutingApplication
data ExtractFromConfig
instance (HasConfigEntry config String, HasServer subApi config) =>
HasServer (ExtractFromConfig :> subApi) config where
type ServerT (ExtractFromConfig :> subApi) m =
String -> ServerT subApi m
route Proxy config delayed =
route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
where
subProxy :: Proxy subApi
subProxy = Proxy
inject config f = f (getConfigEntry config)
data InjectIntoConfig
instance (HasServer subApi (String ': config)) =>
HasServer (InjectIntoConfig :> subApi) config where
type ServerT (InjectIntoConfig :> subApi) m =
ServerT subApi m
route Proxy config delayed =
route subProxy newConfig delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
newConfig = ("injected" :: String) :. config
data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])
instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) =>
HasServer (NamedConfigWithBirdface name subConfig :> subApi) config where
type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =
ServerT subApi m
route Proxy config delayed =
route subProxy subConfig delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
subConfig :: Config subConfig
subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

View file

@ -0,0 +1,125 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.UsingContextSpec where
import Control.Monad.Trans.Except
import Network.Wai
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai
import Servant
import Servant.Server.UsingContextSpec.TestCombinators
spec :: Spec
spec = do
spec1
spec2
spec3
spec4
-- * API
type OneEntryAPI =
ExtractFromContext :> Get '[JSON] String
testServer :: String -> ExceptT ServantErr IO String
testServer s = return s
oneEntryApp :: Application
oneEntryApp =
serveWithContext (Proxy :: Proxy OneEntryAPI) context testServer
where
context :: Context '[String]
context = "contextEntry" :. EmptyContext
type OneEntryTwiceAPI =
"foo" :> ExtractFromContext :> Get '[JSON] String :<|>
"bar" :> ExtractFromContext :> Get '[JSON] String
oneEntryTwiceApp :: Application
oneEntryTwiceApp = serveWithContext (Proxy :: Proxy OneEntryTwiceAPI) context $
testServer :<|>
testServer
where
context :: Context '[String]
context = "contextEntryTwice" :. EmptyContext
-- * tests
spec1 :: Spec
spec1 = do
describe "accessing context entries from custom combinators" $ do
with (return oneEntryApp) $ do
it "allows retrieving a ContextEntry" $ do
get "/" `shouldRespondWith` "\"contextEntry\""
with (return oneEntryTwiceApp) $ do
it "allows retrieving the same ContextEntry twice" $ do
get "/foo" `shouldRespondWith` "\"contextEntryTwice\""
get "/bar" `shouldRespondWith` "\"contextEntryTwice\""
type InjectAPI =
InjectIntoContext :> "untagged" :> ExtractFromContext :>
Get '[JSON] String :<|>
InjectIntoContext :> "tagged" :> ExtractFromContext :>
Get '[JSON] String
injectApp :: Application
injectApp = serveWithContext (Proxy :: Proxy InjectAPI) context $
(\ s -> return s) :<|>
(\ s -> return ("tagged: " ++ s))
where
context = EmptyContext
spec2 :: Spec
spec2 = do
with (return injectApp) $ do
describe "inserting context entries with custom combinators" $ do
it "allows to inject context entries" $ do
get "/untagged" `shouldRespondWith` "\"injected\""
it "allows to inject tagged context entries" $ do
get "/tagged" `shouldRespondWith` "\"tagged: injected\""
type WithBirdfaceAPI =
"foo" :> ExtractFromContext :> Get '[JSON] String :<|>
NamedContextWithBirdface "sub" '[String] :>
"bar" :> ExtractFromContext :> Get '[JSON] String
withBirdfaceApp :: Application
withBirdfaceApp = serveWithContext (Proxy :: Proxy WithBirdfaceAPI) context $
testServer :<|>
testServer
where
context :: Context '[String, (NamedContext "sub" '[String])]
context =
"firstEntry" :.
(NamedContext ("secondEntry" :. EmptyContext)) :.
EmptyContext
spec3 :: Spec
spec3 = do
with (return withBirdfaceApp) $ do
it "allows retrieving different ContextEntries for the same combinator" $ do
get "/foo" `shouldRespondWith` "\"firstEntry\""
get "/bar" `shouldRespondWith` "\"secondEntry\""
type NamedContextAPI =
WithNamedContext "sub" '[String] (
ExtractFromContext :> Get '[JSON] String)
namedContextApp :: Application
namedContextApp = serveWithContext (Proxy :: Proxy NamedContextAPI) context return
where
context :: Context '[NamedContext "sub" '[String]]
context = NamedContext ("descend" :. EmptyContext) :. EmptyContext
spec4 :: Spec
spec4 = do
with (return namedContextApp) $ do
describe "WithNamedContext" $ do
it "allows descending into a subcontext for a given api" $ do
get "/" `shouldRespondWith` "\"descend\""

View file

@ -0,0 +1,72 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | These are custom combinators for Servant.Server.UsingContextSpec.
--
-- (For writing your own combinators you need to import Internal modules, for
-- just *using* combinators that require a Context, you don't. This module is
-- separate from Servant.Server.UsingContextSpec to test that the module imports
-- work out this way.)
module Servant.Server.UsingContextSpec.TestCombinators where
import GHC.TypeLits
import Servant
import Servant.Server.Internal.RoutingApplication
data ExtractFromContext
instance (HasContextEntry context String, HasServer subApi context) =>
HasServer (ExtractFromContext :> subApi) context where
type ServerT (ExtractFromContext :> subApi) m =
String -> ServerT subApi m
route Proxy context delayed =
route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi))
where
subProxy :: Proxy subApi
subProxy = Proxy
inject context f = f (getContextEntry context)
data InjectIntoContext
instance (HasServer subApi (String ': context)) =>
HasServer (InjectIntoContext :> subApi) context where
type ServerT (InjectIntoContext :> subApi) m =
ServerT subApi m
route Proxy context delayed =
route subProxy newContext delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
newContext = ("injected" :: String) :. context
data NamedContextWithBirdface (name :: Symbol) (subContext :: [*])
instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) =>
HasServer (NamedContextWithBirdface name subContext :> subApi) context where
type ServerT (NamedContextWithBirdface name subContext :> subApi) m =
ServerT subApi m
route Proxy context delayed =
route subProxy subContext delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
subContext :: Context subContext
subContext = descendIntoNamedContext (Proxy :: Proxy name) context

View file

@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
StdMethod (..), Verb, addHeader)
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Server (ServantErr (..), Server, err404,
serve, serveWithConfig, Config(EmptyConfig))
serve, serveWithContext, Context(EmptyContext))
import Test.Hspec (Spec, context, describe, it,
shouldBe, shouldContain)
import Test.Hspec.Wai (get, liftIO, matchHeaders,
@ -61,16 +61,16 @@ import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.Router
(tweakResponse, runRouter,
Router, Router'(LeafRouter))
import Servant.Server.Internal.Config
(Config(..), NamedConfig(..))
import Servant.Server.Internal.Context
(Context(..), NamedContext(..))
-- * comprehensive api test
-- This declaration simply checks that all instances are in place.
_ = serveWithConfig comprehensiveAPI comprehensiveApiConfig
_ = serveWithContext comprehensiveAPI comprehensiveApiContext
comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]]
comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig
comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
-- * Specs

View file

@ -41,7 +41,7 @@ library
Servant.API.Sub
Servant.API.Vault
Servant.API.Verbs
Servant.API.WithNamedConfig
Servant.API.WithNamedContext
Servant.Utils.Links
build-depends:
base >=4.7 && <5

View file

@ -23,8 +23,8 @@ module Servant.API (
-- | Is the request made through HTTPS?
module Servant.API.Vault,
-- | Access the location for arbitrary data to be shared by applications and middleware
module Servant.API.WithNamedConfig,
-- | Access config entries in combinators in servant-server
module Servant.API.WithNamedContext,
-- | Access context entries in combinators in servant-server
-- * Actual endpoints, distinguished by HTTP method
module Servant.API.Verbs,
@ -90,7 +90,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte
PutNoContent, PutNonAuthoritative,
ReflectMethod (reflectMethod),
Verb, StdMethod(..))
import Servant.API.WithNamedConfig (WithNamedConfig)
import Servant.API.WithNamedContext (WithNamedContext)
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..),

View file

@ -30,7 +30,7 @@ type ComprehensiveAPI =
Vault :> GET :<|>
Verb 'POST 204 '[JSON] () :<|>
Verb 'POST 204 '[JSON] Int :<|>
WithNamedConfig "foo" '[] GET
WithNamedContext "foo" '[] GET
comprehensiveAPI :: Proxy ComprehensiveAPI
comprehensiveAPI = Proxy

View file

@ -1,21 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
module Servant.API.WithNamedConfig where
import GHC.TypeLits
-- | 'WithNamedConfig' names a specific tagged configuration to use for the
-- combinators in the API. (See also in @servant-server@,
-- @Servant.Server.Config@.) For example:
--
-- > type UseNamedConfigAPI = WithNamedConfig "myConfig" '[String] (
-- > ReqBody '[JSON] Int :> Get '[JSON] Int)
--
-- Both the 'ReqBody' and 'Get' combinators will use the 'NamedConfig' with
-- type tag "myConfig" as their configuration.
--
-- 'Config's are only relevant for @servant-server@.
--
-- For more information, see the tutorial.
data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi

View file

@ -0,0 +1,21 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
module Servant.API.WithNamedContext where
import GHC.TypeLits
-- | 'WithNamedContext' names a specific tagged context to use for the
-- combinators in the API. (See also in @servant-server@,
-- @Servant.Server.Context@.) For example:
--
-- > type UseNamedContextAPI = WithNamedContext "myContext" '[String] (
-- > ReqBody '[JSON] Int :> Get '[JSON] Int)
--
-- Both the 'ReqBody' and 'Get' combinators will use the 'WithNamedContext' with
-- type tag "myContext" as their context.
--
-- 'Context's are only relevant for @servant-server@.
--
-- For more information, see the tutorial.
data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi