config: remove HasConfig and make HasServer take config as a parameter

This commit is contained in:
Sönke Hahn 2016-01-19 00:19:51 +01:00
parent 35bdc54dee
commit df09f8616e
9 changed files with 94 additions and 105 deletions

View file

@ -288,9 +288,8 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
, HasConfig api '[], HasClient api HasClient api, Client api ~ ExceptT ServantError IO ()) =>
, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi

View file

@ -1,10 +1,13 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Aeson import Data.Aeson
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -32,10 +35,10 @@ isGoodCookie ref password = do
data AuthProtected data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where instance (HasConfigEntry config DBConnection, HasServer rest config)
=> HasServer (AuthProtected :> rest) config where
type ServerT (AuthProtected :> rest) m = ServerT rest m type ServerT (AuthProtected :> rest) m = ServerT rest m
type HasConfig (AuthProtected :> rest) config =
(HasConfigEntry config DBConnection, HasConfig rest config)
route Proxy config subserver = WithRequest $ \ request -> route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request

View file

@ -20,4 +20,4 @@ api :: Proxy API
api = Proxy api = Proxy
main :: IO () main :: IO ()
main = run 8080 (serve api EmptyConfig $ mock api) main = run 8080 (serve api EmptyConfig $ mock api Proxy)

View file

@ -2,8 +2,9 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
@ -66,6 +67,7 @@ import Network.HTTP.Types.Status
import Network.Wai import Network.Wai
import Servant import Servant
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.Server.Internal.Config
import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
import Test.QuickCheck.Gen (Gen, generate) import Test.QuickCheck.Gen (Gen, generate)
@ -73,7 +75,7 @@ import Test.QuickCheck.Gen (Gen, generate)
-- than turns them into random-response-generating -- than turns them into random-response-generating
-- request handlers, hence providing an instance for -- request handlers, hence providing an instance for
-- all the combinators of the core /servant/ library. -- all the combinators of the core /servant/ library.
class HasServer api => HasMock api where class HasServer api config => HasMock api config where
-- | Calling this method creates request handlers of -- | Calling this method creates request handlers of
-- the right type to implement the API described by -- the right type to implement the API described by
-- @api@ that just generate random response values of -- @api@ that just generate random response values of
@ -103,65 +105,67 @@ class HasServer api => HasMock api where
-- So under the hood, 'mock' uses the 'IO' bit to generate -- So under the hood, 'mock' uses the 'IO' bit to generate
-- random values of type 'User' and 'Book' every time these -- random values of type 'User' and 'Book' every time these
-- endpoints are requested. -- endpoints are requested.
mock :: Proxy api -> Server api mock :: Proxy api -> Proxy config -> Server api
instance (HasMock a, HasMock b) => HasMock (a :<|> b) where instance (HasMock a config, HasMock b config) => HasMock (a :<|> b) config where
mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b) mock _ config = mock (Proxy :: Proxy a) config :<|> mock (Proxy :: Proxy b) config
instance (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where
mock _ = mock (Proxy :: Proxy rest) mock _ = mock (Proxy :: Proxy rest)
instance (KnownSymbol s, FromHttpApiData a, HasMock rest) => HasMock (Capture s a :> rest) where instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) => HasMock (Capture s a :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest => HasMock (RemoteHost :> rest) where instance HasMock rest config => HasMock (RemoteHost :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest => HasMock (IsSecure :> rest) where instance HasMock rest config => HasMock (IsSecure :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest => HasMock (Vault :> rest) where instance HasMock rest config => HasMock (Vault :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance HasMock rest => HasMock (HttpVersion :> rest) where instance HasMock rest config => HasMock (HttpVersion :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol s, FromHttpApiData a, HasMock rest) instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)
=> HasMock (QueryParam s a :> rest) where => HasMock (QueryParam s a :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol s, FromHttpApiData a, HasMock rest) instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)
=> HasMock (QueryParams s a :> rest) where => HasMock (QueryParams s a :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where
mock _ = \_ -> mock (Proxy :: Proxy rest) mock _ config = \_ -> mock (Proxy :: Proxy rest) config
instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes a) where => HasMock (Verb method status ctypes a) config where
mock _ = mockArbitrary mock _ _ = mockArbitrary
instance OVERLAPPING_ instance OVERLAPPING_
(GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),
Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes (Headers headerTypes a)) where => HasMock (Verb method status ctypes (Headers headerTypes a)) config where
mock _ = mockArbitrary mock _ _ = mockArbitrary
instance HasMock Raw where instance HasMock Raw config where
mock _ = \_req respond -> do mock _ _ = \_req respond -> do
bdy <- genBody bdy <- genBody
respond $ responseLBS status200 [] bdy respond $ responseLBS status200 [] bdy
where genBody = pack <$> generate (vector 100 :: Gen [Char]) where genBody = pack <$> generate (vector 100 :: Gen [Char])
instance HasMock rest => HasMock (WithNamedConfig name config rest) where instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) =>
mock _ = mock (Proxy :: Proxy rest) HasMock (WithNamedConfig name subConfig rest) config where
mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig)
mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary :: (MonadIO m, Arbitrary a) => m a
mockArbitrary = liftIO (generate arbitrary) mockArbitrary = liftIO (generate arbitrary)

View file

@ -1,5 +1,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -21,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Mock import Servant.Mock
-- This declaration simply checks that all instances are in place. -- This declaration simply checks that all instances are in place.
_ = mock comprehensiveAPI _ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]])
data Body data Body
= Body = Body
@ -50,7 +52,7 @@ spec = do
context "Get" $ do context "Get" $ do
let api :: Proxy (Get '[JSON] Body) let api :: Proxy (Get '[JSON] Body)
api = Proxy api = Proxy
app = serve api (mock api) app = serve api EmptyConfig (mock api Proxy)
with (return app) $ do with (return app) $ do
it "serves arbitrary response bodies" $ do it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{ get "/" `shouldRespondWith` 200{
@ -62,8 +64,8 @@ spec = do
withHeader = Proxy withHeader = Proxy
withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))
withoutHeader = Proxy withoutHeader = Proxy
toApp :: HasMock api => Proxy api -> IO Application toApp :: (HasMock api '[]) => Proxy api -> IO Application
toApp api = return $ serve api (mock api) toApp api = return $ serve api EmptyConfig (mock api (Proxy :: Proxy '[]))
with (toApp withHeader) $ do with (toApp withHeader) $ do
it "serves arbitrary response bodies" $ do it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{ get "/" `shouldRespondWith` 200{

View file

@ -110,8 +110,8 @@ import Servant.Server.Internal.Enter
-- > main :: IO () -- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
-- --
serve :: (HasConfig layout a, HasServer layout) serve :: (HasServer layout config)
=> Proxy layout -> Config a -> Server layout -> Application => Proxy layout -> Config config -> Server layout -> Application
serve p config server = toApplication (runRouter (route p config d)) serve p config server = toApplication (runRouter (route p config d))
where where
d = Delayed r r r (\ _ _ -> Route server) d = Delayed r r r (\ _ _ -> Route server)

View file

@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -68,11 +69,10 @@ import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
class HasServer layout where class HasServer layout config where
type ServerT layout (m :: * -> *) :: * type ServerT layout (m :: * -> *) :: *
type HasConfig layout (c :: [*]) :: Constraint
route :: HasConfig layout config => Proxy layout -> Config config -> Delayed (Server layout) -> Router route :: Proxy layout -> Config config -> Delayed (Server layout) -> Router
type Server layout = ServerT layout (ExceptT ServantErr IO) type Server layout = ServerT layout (ExceptT ServantErr IO)
@ -89,10 +89,9 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)
-- > server = listAllBooks :<|> postBook -- > server = listAllBooks :<|> postBook
-- > where listAllBooks = ... -- > where listAllBooks = ...
-- > postBook book = ... -- > postBook book = ...
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where instance (HasServer a config, HasServer b config) => HasServer (a :<|> b) config where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c)
route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
(route pb config ((\ (_ :<|> b) -> b) <$> server)) (route pb config ((\ (_ :<|> b) -> b) <$> server))
@ -119,12 +118,11 @@ captured _ = parseUrlPieceMaybe
-- > server = getBook -- > server = getBook
-- > where getBook :: Text -> ExceptT ServantErr IO Book -- > where getBook :: Text -> ExceptT ServantErr IO Book
-- > getBook isbn = ... -- > getBook isbn = ...
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config)
=> HasServer (Capture capture a :> sublayout) where => HasServer (Capture capture a :> sublayout) config where
type ServerT (Capture capture a :> sublayout) m = type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)
route Proxy config d = route Proxy config d =
DynamicRouter $ \ first -> DynamicRouter $ \ first ->
@ -198,10 +196,9 @@ methodRouterHeaders method proxy status action = LeafRouter route'
instance OVERLAPPABLE_ instance OVERLAPPABLE_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
) => HasServer (Verb method status ctypes a) where ) => HasServer (Verb method status ctypes a) config where
type ServerT (Verb method status ctypes a) m = m a type ServerT (Verb method status ctypes a) m = m a
type HasConfig (Verb method status ctypes a) c = ()
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
@ -210,10 +207,9 @@ instance OVERLAPPABLE_
instance OVERLAPPING_ instance OVERLAPPING_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a) , GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) where ) => HasServer (Verb method status ctypes (Headers h a)) config where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
type HasConfig (Verb method status ctypes (Headers h a)) c = ()
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
@ -239,12 +235,11 @@ instance OVERLAPPING_
-- > server = viewReferer -- > server = viewReferer
-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer -- > where viewReferer :: Referer -> ExceptT ServantErr IO referer
-- > viewReferer referer = return referer -- > viewReferer referer = return referer
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
=> HasServer (Header sym a :> sublayout) where => HasServer (Header sym a :> sublayout) config where
type ServerT (Header sym a :> sublayout) m = type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c
route Proxy config subserver = WithRequest $ \ request -> route Proxy config subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
@ -272,12 +267,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] -- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]
-- > getBooksBy Nothing = ...return all books... -- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author... -- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
=> HasServer (QueryParam sym a :> sublayout) where => HasServer (QueryParam sym a :> sublayout) config where
type ServerT (QueryParam sym a :> sublayout) m = type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c
route Proxy config subserver = WithRequest $ \ request -> route Proxy config subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -309,12 +303,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
-- > server = getBooksBy -- > server = getBooksBy
-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] -- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]
-- > getBooksBy authors = ...return all books by these authors... -- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
=> HasServer (QueryParams sym a :> sublayout) where => HasServer (QueryParams sym a :> sublayout) config where
type ServerT (QueryParams sym a :> sublayout) m = type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT sublayout m
type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c
route Proxy config subserver = WithRequest $ \ request -> route Proxy config subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -341,12 +334,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
-- > server = getBooks -- > server = getBooks
-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] -- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout config)
=> HasServer (QueryFlag sym :> sublayout) where => HasServer (QueryFlag sym :> sublayout) config where
type ServerT (QueryFlag sym :> sublayout) m = type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT sublayout m
type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c
route Proxy config subserver = WithRequest $ \ request -> route Proxy config subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -367,10 +359,9 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images" -- > server = serveDirectory "/var/www/images"
instance HasServer Raw where instance HasServer Raw config where
type ServerT Raw m = Application type ServerT Raw m = Application
type HasConfig Raw c = ()
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication r <- runDelayed rawApplication
@ -400,12 +391,11 @@ instance HasServer Raw where
-- > server = postBook -- > server = postBook
-- > where postBook :: Book -> ExceptT ServantErr IO Book -- > where postBook :: Book -> ExceptT ServantErr IO Book
-- > postBook book = ...insert into your db... -- > postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer sublayout instance ( AllCTUnrender list a, HasServer sublayout config
) => HasServer (ReqBody list a :> sublayout) where ) => HasServer (ReqBody list a :> sublayout) config where
type ServerT (ReqBody list a :> sublayout) m = type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c
route Proxy config subserver = WithRequest $ \ request -> route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request)) route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))
@ -426,42 +416,37 @@ instance ( AllCTUnrender list a, HasServer sublayout
-- | Make sure the incoming request starts with @"/path"@, strip it and -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where instance (KnownSymbol path, HasServer sublayout config) => HasServer (path :> sublayout) config where
type ServerT (path :> sublayout) m = ServerT sublayout m type ServerT (path :> sublayout) m = ServerT sublayout m
type HasConfig (path :> sublayout) c = HasConfig sublayout c
route Proxy config subserver = StaticRouter $ route Proxy config subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath)) M.singleton (cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) config subserver) (route (Proxy :: Proxy sublayout) config subserver)
where proxyPath = Proxy :: Proxy path where proxyPath = Proxy :: Proxy path
instance HasServer api => HasServer (RemoteHost :> api) where instance HasServer api config => HasServer (RemoteHost :> api) config where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
type HasConfig (RemoteHost :> api) c = HasConfig api c
route Proxy config subserver = WithRequest $ \req -> route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req) route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)
instance HasServer api => HasServer (IsSecure :> api) where instance HasServer api config => HasServer (IsSecure :> api) config where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
type HasConfig (IsSecure :> api) c = HasConfig api c
route Proxy config subserver = WithRequest $ \req -> route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ secure req) route (Proxy :: Proxy api) config (passToServer subserver $ secure req)
where secure req = if isSecure req then Secure else NotSecure where secure req = if isSecure req then Secure else NotSecure
instance HasServer api => HasServer (Vault :> api) where instance HasServer api config => HasServer (Vault :> api) config where
type ServerT (Vault :> api) m = Vault -> ServerT api m type ServerT (Vault :> api) m = Vault -> ServerT api m
type HasConfig (Vault :> api) c = HasConfig api c
route Proxy config subserver = WithRequest $ \req -> route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ vault req) route (Proxy :: Proxy api) config (passToServer subserver $ vault req)
instance HasServer api => HasServer (HttpVersion :> api) where instance HasServer api config => HasServer (HttpVersion :> api) config where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
type HasConfig (HttpVersion :> api) c = HasConfig api c
route Proxy config subserver = WithRequest $ \req -> route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
@ -477,11 +462,11 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP
-- * configs -- * configs
instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig)
=> HasServer (WithNamedConfig name subConfig subApi) config where
type ServerT (WithNamedConfig name subConfig subApi) m = type ServerT (WithNamedConfig name subConfig subApi) m =
ServerT subApi m ServerT subApi m
type HasConfig (WithNamedConfig name subConfig subApi) config =
(HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
route Proxy config delayed = route Proxy config delayed =
route subProxy subConfig delayed route subProxy subConfig delayed

View file

@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -24,13 +25,11 @@ import Servant.Server.Internal.RoutingApplication
data ExtractFromConfig data ExtractFromConfig
instance (HasServer subApi) => instance (HasConfigEntry config String, HasServer subApi config) =>
HasServer (ExtractFromConfig :> subApi) where HasServer (ExtractFromConfig :> subApi) config where
type ServerT (ExtractFromConfig :> subApi) m = type ServerT (ExtractFromConfig :> subApi) m =
String -> ServerT subApi m String -> ServerT subApi m
type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) =
(HasConfigEntry c String, HasConfig subApi c)
route Proxy config delayed = route Proxy config delayed =
route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
@ -42,13 +41,11 @@ instance (HasServer subApi) =>
data InjectIntoConfig data InjectIntoConfig
instance (HasServer subApi) => instance (HasServer subApi (String ': config)) =>
HasServer (InjectIntoConfig :> subApi) where HasServer (InjectIntoConfig :> subApi) config where
type ServerT (InjectIntoConfig :> subApi) m = type ServerT (InjectIntoConfig :> subApi) m =
ServerT subApi m ServerT subApi m
type HasConfig (InjectIntoConfig :> subApi) c =
(HasConfig subApi (String ': c))
route Proxy config delayed = route Proxy config delayed =
route subProxy newConfig delayed route subProxy newConfig delayed
@ -60,13 +57,11 @@ instance (HasServer subApi) =>
data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])
instance (HasServer subApi) => instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) =>
HasServer (NamedConfigWithBirdface name subConfig :> subApi) where HasServer (NamedConfigWithBirdface name subConfig :> subApi) config where
type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =
ServerT subApi m ServerT subApi m
type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config =
(HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
route Proxy config delayed = route Proxy config delayed =
route subProxy subConfig delayed route subProxy subConfig delayed

View file

@ -1,14 +1,15 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Servant.ServerSpec where module Servant.ServerSpec where