diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fb9e835a..4cb1ef4c 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -288,9 +288,8 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a - , HasConfig api '[], HasClient api - , Client api ~ ExceptT ServantError IO ()) => + WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a, + HasClient api, Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 87f1fcc7..f2cebb4f 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} import Data.Aeson import Data.ByteString (ByteString) @@ -32,10 +35,10 @@ isGoodCookie ref password = do 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 HasConfig (AuthProtected :> rest) config = - (HasConfigEntry config DBConnection, HasConfig rest config) route Proxy config subserver = WithRequest $ \ request -> route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 6c63c0e4..7f08f352 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -20,4 +20,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api EmptyConfig $ mock api) +main = run 8080 (serve api EmptyConfig $ mock api Proxy) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index ae6afd55..2c447ca0 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -2,8 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -66,6 +67,7 @@ import Network.HTTP.Types.Status import Network.Wai import Servant import Servant.API.ContentTypes +import Servant.Server.Internal.Config import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) import Test.QuickCheck.Gen (Gen, generate) @@ -73,7 +75,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 => HasMock api where +class HasServer api config => HasMock api config 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 @@ -103,65 +105,67 @@ class HasServer api => HasMock api 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 -> Server api + mock :: Proxy api -> Proxy config -> Server api -instance (HasMock a, HasMock b) => HasMock (a :<|> b) where - mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b) +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 (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where +instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where mock _ = mock (Proxy :: Proxy rest) -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) => HasMock (Capture s a :> rest) 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 (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (RemoteHost :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (RemoteHost :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (IsSecure :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (IsSecure :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (Vault :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (Vault :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (HttpVersion :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (HttpVersion :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) - => HasMock (QueryParam s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +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) - => HasMock (QueryParams s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +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, HasMock rest) => HasMock (QueryFlag s :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes a) where - mock _ = mockArbitrary + => HasMock (Verb method status ctypes a) config 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)) where - mock _ = mockArbitrary + => HasMock (Verb method status ctypes (Headers headerTypes a)) config where + mock _ _ = mockArbitrary -instance HasMock Raw where - mock _ = \_req respond -> do +instance HasMock Raw config where + mock _ _ = \_req respond -> do bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) -instance HasMock rest => HasMock (WithNamedConfig name config rest) where - mock _ = mock (Proxy :: Proxy rest) +instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) => + HasMock (WithNamedConfig name subConfig rest) config where + + mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig) mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index 24cad324..cd369ee6 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -21,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Mock -- This declaration simply checks that all instances are in place. -_ = mock comprehensiveAPI +_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]]) data Body = Body @@ -50,7 +52,7 @@ spec = do context "Get" $ do let api :: Proxy (Get '[JSON] Body) api = Proxy - app = serve api (mock api) + app = serve api EmptyConfig (mock api Proxy) with (return app) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ @@ -62,8 +64,8 @@ spec = do withHeader = Proxy withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) withoutHeader = Proxy - toApp :: HasMock api => Proxy api -> IO Application - toApp api = return $ serve api (mock api) + toApp :: (HasMock api '[]) => Proxy api -> IO Application + toApp api = return $ serve api EmptyConfig (mock api (Proxy :: Proxy '[])) with (toApp withHeader) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 5ef8498d..b8de9cf5 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -110,8 +110,8 @@ import Servant.Server.Internal.Enter -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: (HasConfig layout a, HasServer layout) - => Proxy layout -> Config a -> Server layout -> Application +serve :: (HasServer layout config) + => Proxy layout -> Config config -> Server layout -> Application serve p config server = toApplication (runRouter (route p config d)) where d = Delayed r r r (\ _ _ -> Route server) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a5ab7200..17ecbbac 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -68,11 +69,10 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -class HasServer layout where +class HasServer layout config where 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) @@ -89,10 +89,9 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > 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 HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c) route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) (route pb config ((\ (_ :<|> b) -> b) <$> server)) @@ -119,12 +118,11 @@ captured _ = parseUrlPieceMaybe -- > server = getBook -- > where getBook :: Text -> ExceptT ServantErr IO Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) - => HasServer (Capture capture a :> sublayout) where +instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config) + => HasServer (Capture capture a :> sublayout) config where type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c) route Proxy config d = DynamicRouter $ \ first -> @@ -198,10 +196,9 @@ methodRouterHeaders method proxy status action = LeafRouter route' instance OVERLAPPABLE_ ( 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 HasConfig (Verb method status ctypes a) c = () route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -210,10 +207,9 @@ instance OVERLAPPABLE_ instance OVERLAPPING_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , 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 HasConfig (Verb method status ctypes (Headers h a)) c = () route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -239,12 +235,11 @@ instance OVERLAPPING_ -- > server = viewReferer -- > where viewReferer :: Referer -> ExceptT ServantErr IO referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (Header sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) + => HasServer (Header sym a :> sublayout) config where type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ 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] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (QueryParam sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) + => HasServer (QueryParam sym a :> sublayout) config where type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request @@ -309,12 +303,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > server = getBooksBy -- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (QueryParams sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) + => HasServer (QueryParams sym a :> sublayout) config where type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request @@ -341,12 +334,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > 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) - => HasServer (QueryFlag sym :> sublayout) where +instance (KnownSymbol sym, HasServer sublayout config) + => HasServer (QueryFlag sym :> sublayout) config where type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request @@ -367,10 +359,9 @@ instance (KnownSymbol sym, HasServer sublayout) -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" -instance HasServer Raw where +instance HasServer Raw config where type ServerT Raw m = Application - type HasConfig Raw c = () route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication @@ -400,12 +391,11 @@ instance HasServer Raw where -- > server = postBook -- > where postBook :: Book -> ExceptT ServantErr IO Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout - ) => HasServer (ReqBody list a :> sublayout) where +instance ( AllCTUnrender list a, HasServer sublayout config + ) => HasServer (ReqBody list a :> sublayout) config where type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ 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 -- 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 HasConfig (path :> sublayout) c = HasConfig sublayout c route Proxy config subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) (route (Proxy :: Proxy sublayout) config subserver) 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 HasConfig (RemoteHost :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \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 HasConfig (IsSecure :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \req -> route (Proxy :: Proxy api) config (passToServer subserver $ secure req) 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 HasConfig (Vault :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \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 HasConfig (HttpVersion :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \req -> route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) @@ -477,11 +462,11 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP -- * 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 = ServerT subApi m - type HasConfig (WithNamedConfig name subConfig subApi) config = - (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) route Proxy config delayed = route subProxy subConfig delayed diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs index 53f00f21..1da892e8 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -24,13 +25,11 @@ import Servant.Server.Internal.RoutingApplication data ExtractFromConfig -instance (HasServer subApi) => - HasServer (ExtractFromConfig :> subApi) where +instance (HasConfigEntry config String, HasServer subApi config) => + HasServer (ExtractFromConfig :> subApi) config where type ServerT (ExtractFromConfig :> subApi) m = String -> ServerT subApi m - type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) = - (HasConfigEntry c String, HasConfig subApi c) route Proxy config delayed = route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) @@ -42,13 +41,11 @@ instance (HasServer subApi) => data InjectIntoConfig -instance (HasServer subApi) => - HasServer (InjectIntoConfig :> subApi) where +instance (HasServer subApi (String ': config)) => + HasServer (InjectIntoConfig :> subApi) config where type ServerT (InjectIntoConfig :> subApi) m = ServerT subApi m - type HasConfig (InjectIntoConfig :> subApi) c = - (HasConfig subApi (String ': c)) route Proxy config delayed = route subProxy newConfig delayed @@ -60,13 +57,11 @@ instance (HasServer subApi) => data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) -instance (HasServer subApi) => - HasServer (NamedConfigWithBirdface name subConfig :> subApi) where +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 - type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config = - (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) route Proxy config delayed = route subProxy subConfig delayed diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 21fabd38..04461566 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} module Servant.ServerSpec where