renaming: Config -> Context
This commit is contained in:
Sönke Hahn
parent
65d0a51d60
commit
8ef4d4543b
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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/
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.*
|
||||
|
|
|
|||
|
|
@ -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 ())
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
99
servant-server/src/Servant/Server/Internal/Context.hs
Normal file
99
servant-server/src/Servant/Server/Internal/Context.hs
Normal 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
|
||||
|
|
@ -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)
|
||||
61
servant-server/test/Servant/Server/Internal/ContextSpec.hs
Normal file
61
servant-server/test/Servant/Server/Internal/ContextSpec.hs
Normal 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)
|
||||
|
|
@ -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\""
|
||||
|
|
@ -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
|
||||
125
servant-server/test/Servant/Server/UsingContextSpec.hs
Normal file
125
servant-server/test/Servant/Server/UsingContextSpec.hs
Normal 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\""
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 (..),
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
21
servant/src/Servant/API/WithNamedContext.hs
Normal file
21
servant/src/Servant/API/WithNamedContext.hs
Normal 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
|
||||
Loading…
Reference in New Issue
Block a user