server: added Config machinery

.travis.yml

@@ -25,7 +25,7 @@ install:
   - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
 
 script:
-  - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done
+  - for package in $(cat sources.txt); do (echo testing $package && cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done
 
 cache:
   directories:

servant-client/test/Servant/ClientSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                    #-}
+{-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE FlexibleContexts       #-}
@@ -114,7 +115,7 @@ api :: Proxy Api
 api = Proxy
 
 server :: Application
-server = serve api (
+server = serve api EmptyConfig (
        return alice
   :<|> return NoContent
   :<|> (\ name -> return $ Person name 0)
@@ -141,7 +142,7 @@ failApi :: Proxy FailApi
 failApi = Proxy
 
 failServer :: Application
-failServer = serve failApi (
+failServer = serve failApi EmptyConfig (
        (\ _request respond -> respond $ responseLBS ok200 [] "")
   :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
   :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
@@ -231,7 +232,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
 
 wrappedApiSpec :: Spec
 wrappedApiSpec = describe "error status codes" $ do
-  let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
+  let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" []
   context "are correctly handled by the client" $
     let test :: (WrappedApi, String) -> Spec
         test (WrappedApi api, desc) =
@@ -287,8 +288,9 @@ 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,
+  WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a
-                 HasClient api, Client api ~ ExceptT ServantError IO ()) =>
+                 , HasConfig api '[], HasClient api
+                 , Client api ~ ExceptT ServantError IO ()) =>
     Proxy api -> WrappedApi
 
 

servant-examples/auth-combinator/auth-combinator.hs

@@ -8,6 +8,7 @@
 
 import           Data.Aeson
 import           Data.ByteString          (ByteString)
+import           Data.IORef
 import           Data.Text                (Text)
 import           GHC.Generics
 import           Network.Wai
@@ -18,23 +19,32 @@ import           Servant.Server.Internal
 -- Pretty much stolen/adapted from
 -- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
 
-type DBLookup = ByteString -> IO Bool
+type DBConnection = IORef [ByteString]
+type DBLookup = DBConnection -> ByteString -> IO Bool
+
+initDB :: IO DBConnection
+initDB = newIORef ["good password"]
 
 isGoodCookie :: DBLookup
-isGoodCookie = return . (== "good password")
+isGoodCookie ref password = do
+  allowed <- readIORef ref
+  return (password `elem` allowed)
 
 data AuthProtected
 
 instance HasServer rest => HasServer (AuthProtected :> rest) where
   type ServerT (AuthProtected :> rest) m = ServerT rest m
+  type HasConfig (AuthProtected :> rest) config =
+    (HasConfigEntry config DBConnection, HasConfig rest config)
 
-  route Proxy subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request
+    route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request
       where
         cookieCheck req = case lookup "Cookie" (requestHeaders req) of
             Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
             Just v  -> do
-              authGranted <- isGoodCookie v
+              let dbConnection = getConfigEntry config
+              authGranted <- isGoodCookie dbConnection v
               if authGranted
                 then return $ Route ()
                 else return $ FailFatal err403 { errBody = "Invalid cookie" }
@@ -66,7 +76,10 @@ server = return prvdata :<|> return pubdata
         pubdata = [PublicData "this is a public piece of data"]
 
 main :: IO ()
-main = run 8080 (serve api server)
+main = do
+  dbConnection <- initDB
+  let config = dbConnection :. EmptyConfig
+  run 8080 (serve api config server)
 
 {- Sample session:
 $ curl http://localhost:8080/

servant-examples/socket-io-chat/socket-io-chat.hs

@@ -38,7 +38,7 @@ server sHandler = socketIOHandler
 
 
 app :: WaiMonad () -> Application
-app sHandler = serve api $ server sHandler
+app sHandler = serve api EmptyConfig $ server sHandler
 
 port :: Int
 port = 3001

servant-examples/tutorial/T1.hs

@@ -42,4 +42,4 @@ server :: Server UserAPI
 server = return users
 
 app :: Application
-app = serve userAPI server
+app = serve userAPI EmptyConfig server

servant-examples/tutorial/T10.hs

@@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs
         plain = ("Content-Type", "text/plain")
 
 app :: Application
-app = serve api server
+app = serve api EmptyConfig server

servant-examples/tutorial/T2.hs

@@ -49,4 +49,4 @@ server = return users
     :<|> return isaac
 
 app :: Application
-app = serve userAPI server
+app = serve userAPI EmptyConfig server

servant-examples/tutorial/T3.hs

@@ -81,4 +81,4 @@ server = position
         marketing clientinfo = return (emailForClient clientinfo)
 
 app :: Application
-app = serve api server
+app = serve api EmptyConfig server

servant-examples/tutorial/T4.hs

@@ -60,4 +60,4 @@ server :: Server PersonAPI
 server = return persons
 
 app :: Application
-app = serve personAPI server
+app = serve personAPI EmptyConfig server

servant-examples/tutorial/T5.hs

@@ -34,4 +34,4 @@ server = do
   where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }
 
 app :: Application
-app = serve ioAPI server
+app = serve ioAPI EmptyConfig server

servant-examples/tutorial/T6.hs

@@ -15,4 +15,4 @@ server :: Server API
 server = serveDirectory "tutorial"
 
 app :: Application
-app = serve api server
+app = serve api EmptyConfig server

servant-examples/tutorial/T7.hs

@@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT
         readerToEither = Nat $ \r -> return (runReader r "hi")
 
 app :: Application
-app = serve readerAPI readerServer
+app = serve readerAPI EmptyConfig readerServer

servant-examples/tutorial/T9.hs

@@ -102,4 +102,4 @@ writeJSFiles = do
   TIO.writeFile "tutorial/t9/jq.js" jq
 
 app :: Application
-app = serve api' server'
+app = serve api' EmptyConfig server'

servant-examples/wai-middleware/wai-middleware.hs

@@ -41,11 +41,11 @@ server = return products
 
 -- logStdout :: Middleware
 -- i.e, logStdout :: Application -> Application
--- serve :: Proxy api -> Server api -> Application
+-- serve :: Proxy api -> Config a -> Server api -> Application
 -- so applying a middleware is really as simple as
 -- applying a function to the result of 'serve'
 app :: Application
-app = logStdout (serve simpleAPI server)
+app = logStdout (serve simpleAPI EmptyConfig server)
 
 main :: IO ()
 main = run 8080 app

servant-mock/example/main.hs

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

servant-server/example/greet.hs

@@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
 -- Turn the server into a WAI app. 'serve' is provided by servant,
 -- more precisely by the Servant.Server module.
 test :: Application
-test = serve testApi server
+test = serve testApi EmptyConfig server
 
 -- Run the server.
 --

servant-server/servant-server.cabal

@@ -37,6 +37,7 @@ library
     Servant
     Servant.Server
     Servant.Server.Internal
+    Servant.Server.Internal.Config
     Servant.Server.Internal.Enter
     Servant.Server.Internal.Router
     Servant.Server.Internal.RoutingApplication
@@ -94,10 +95,13 @@ test-suite spec
   hs-source-dirs: test
   main-is: Spec.hs
   other-modules:
+      Servant.Server.ErrorSpec
+      Servant.Server.Internal.ConfigSpec
       Servant.Server.Internal.EnterSpec
       Servant.ServerSpec
+      Servant.Server.UsingConfigSpec
+      Servant.Server.UsingConfigSpec.TestCombinators
       Servant.Utils.StaticFilesSpec
-      Servant.Server.ErrorSpec
   build-depends:
       base == 4.*
     , aeson
@@ -115,6 +119,7 @@ test-suite spec
     , servant
     , servant-server
     , string-conversions
+    , should-not-typecheck == 2.*
     , temporary
     , text
     , transformers

servant-server/src/Servant/Server.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
@@ -35,6 +36,10 @@ module Servant.Server
   , generalizeNat
   , tweakResponse
 
+  -- * Config
+  , Config(..)
+  , NamedConfig(..)
+
     -- * Default error type
   , ServantErr(..)
     -- ** 3XX
@@ -96,14 +101,18 @@ import           Servant.Server.Internal.Enter
 -- > myApi :: Proxy MyApi
 -- > myApi = Proxy
 -- >
+-- > config :: Config '[]
+-- > config = EmptyConfig
+-- >
 -- > app :: Application
--- > app = serve myApi server
+-- > app = serve myApi config server
 -- >
 -- > main :: IO ()
 -- > main = Network.Wai.Handler.Warp.run 8080 app
 --
-serve :: HasServer layout => Proxy layout -> Server layout -> Application
+serve :: (HasConfig layout a, HasServer layout)
-serve p server = toApplication (runRouter (route p d))
+    => Proxy layout -> Config a -> Server layout -> Application
+serve p config server = toApplication (runRouter (route p config d))
   where
     d = Delayed r r r (\ _ _ -> Route server)
     r = return (Route ())

servant-server/src/Servant/Server/Internal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                        #-}
+{-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -13,6 +14,7 @@
 
 module Servant.Server.Internal
   ( module Servant.Server.Internal
+  , module Servant.Server.Internal.Config
   , module Servant.Server.Internal.Router
   , module Servant.Server.Internal.RoutingApplication
   , module Servant.Server.Internal.ServantErr
@@ -30,6 +32,7 @@ import           Data.String                (fromString)
 import           Data.String.Conversions    (cs, (<>))
 import           Data.Text                  (Text)
 import           Data.Typeable
+import           GHC.Exts                   (Constraint)
 import           GHC.TypeLits               (KnownNat, KnownSymbol, natVal,
                                              symbolVal)
 import           Network.HTTP.Types         hiding (Header, ResponseHeaders)
@@ -49,7 +52,8 @@ import           Servant.API                 ((:<|>) (..), (:>), Capture,
                                               Verb, ReflectMethod(reflectMethod),
                                               IsSecure(..), Header,
                                               QueryFlag, QueryParam, QueryParams,
-                                              Raw, RemoteHost, ReqBody, Vault)
+                                              Raw, RemoteHost, ReqBody, Vault,
+                                              WithNamedConfig)
 import           Servant.API.ContentTypes    (AcceptHeader (..),
                                               AllCTRender (..),
                                               AllCTUnrender (..),
@@ -58,6 +62,7 @@ import           Servant.API.ContentTypes    (AcceptHeader (..),
 import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
                                               getResponse)
 
+import           Servant.Server.Internal.Config
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
@@ -65,8 +70,9 @@ import           Servant.Server.Internal.ServantErr
 
 class HasServer layout where
   type ServerT layout (m :: * -> *) :: *
+  type HasConfig layout (c :: [*]) :: Constraint
 
-  route :: Proxy layout -> Delayed (Server layout) -> Router
+  route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
 
 type Server layout = ServerT layout (ExceptT ServantErr IO)
 
@@ -86,9 +92,10 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)
 instance (HasServer a, HasServer b) => HasServer (a :<|> b) 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 server = choice (route pa ((\ (a :<|> _) -> a) <$> server))
+  route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
-                              (route pb ((\ (_ :<|> b) -> b) <$> server))
+                                     (route pb config ((\ (_ :<|> b) -> b) <$> server))
     where pa = Proxy :: Proxy a
           pb = Proxy :: Proxy b
 
@@ -117,10 +124,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (Capture capture a :> sublayout) m =
      a -> ServerT sublayout m
+  type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)
 
-  route Proxy d =
+  route Proxy config d =
     DynamicRouter $ \ first ->
         route (Proxy :: Proxy sublayout)
+              config
               (addCapture d $ case captured captureProxy first of
                  Nothing -> return $ Fail err404
                  Just v  -> return $ Route v
@@ -192,8 +201,9 @@ instance OVERLAPPABLE_
          ) => HasServer (Verb method status ctypes a) 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
+  route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
     where method = reflectMethod (Proxy :: Proxy method)
           status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
 
@@ -203,8 +213,9 @@ instance OVERLAPPING_
          ) => HasServer (Verb method status ctypes (Headers h a)) 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
+  route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
     where method = reflectMethod (Proxy :: Proxy method)
           status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
 
@@ -233,10 +244,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (Header sym a :> sublayout) m =
     Maybe a -> ServerT sublayout m
+  type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
     let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
-    in  route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
+    in  route (Proxy :: Proxy sublayout) config (passToServer subserver mheader)
     where str = fromString $ symbolVal (Proxy :: Proxy sym)
 
 -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
@@ -265,8 +277,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (QueryParam sym a :> sublayout) m =
     Maybe a -> ServerT sublayout m
+  type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
     let querytext = parseQueryText $ rawQueryString request
         param =
           case lookup paramname querytext of
@@ -274,7 +287,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
             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) (passToServer subserver param)
+    in route (Proxy :: Proxy sublayout) config (passToServer subserver param)
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
 -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@@ -301,15 +314,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (QueryParams sym a :> sublayout) m =
     [a] -> ServerT sublayout m
+  type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy subserver = WithRequest $ \ request ->
+  route Proxy config 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) (passToServer subserver values)
+    in  route (Proxy :: Proxy sublayout) config (passToServer subserver values)
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
           convert Nothing = Nothing
@@ -332,14 +346,15 @@ instance (KnownSymbol sym, HasServer sublayout)
 
   type ServerT (QueryFlag sym :> sublayout) m =
     Bool -> ServerT sublayout m
+  type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c
 
-  route Proxy subserver = WithRequest $ \ request ->
+  route Proxy config 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) (passToServer subserver param)
+    in  route (Proxy :: Proxy sublayout) config (passToServer subserver param)
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           examine v | v == "true" || v == "1" || v == "" = True
                     | otherwise = False
@@ -355,8 +370,9 @@ instance (KnownSymbol sym, HasServer sublayout)
 instance HasServer Raw where
 
   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
     case r of
       Route app   -> app request (respond . Route)
@@ -389,9 +405,10 @@ instance ( AllCTUnrender list a, HasServer sublayout
 
   type ServerT (ReqBody list a :> sublayout) m =
     a -> ServerT sublayout m
+  type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))
+    route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))
     where
       bodyCheck request = do
         -- See HTTP RFC 2616, section 7.2.1
@@ -412,37 +429,42 @@ instance ( AllCTUnrender list a, HasServer sublayout
 instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
 
   type ServerT (path :> sublayout) m = ServerT sublayout m
+  type HasConfig (path :> sublayout) c = HasConfig sublayout c
 
-  route Proxy subserver = StaticRouter $
+  route Proxy config subserver = StaticRouter $
     M.singleton (cs (symbolVal proxyPath))
-                (route (Proxy :: Proxy sublayout) subserver)
+                (route (Proxy :: Proxy sublayout) config subserver)
     where proxyPath = Proxy :: Proxy path
 
 instance HasServer api => HasServer (RemoteHost :> api) where
   type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
+  type HasConfig (RemoteHost :> api) c = HasConfig api c
 
-  route Proxy subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req)
+    route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)
 
 instance HasServer api => HasServer (IsSecure :> api) where
   type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
+  type HasConfig (IsSecure :> api) c = HasConfig api c
 
-  route Proxy subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ secure 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
   type ServerT (Vault :> api) m = Vault -> ServerT api m
+  type HasConfig (Vault :> api) c = HasConfig api c
 
-  route Proxy subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ vault req)
+    route (Proxy :: Proxy api) config (passToServer subserver $ vault req)
 
 instance HasServer api => HasServer (HttpVersion :> api) where
   type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
+  type HasConfig (HttpVersion :> api) c = HasConfig api c
 
-  route Proxy subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req)
+    route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
 
 pathIsEmpty :: Request -> Bool
 pathIsEmpty = go . pathInfo
@@ -452,3 +474,20 @@ pathIsEmpty = go . pathInfo
 
 ct_wildcard :: B.ByteString
 ct_wildcard = "*" <> "/" <> "*" -- Because CPP
+
+-- * configs
+
+instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) 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
+    where
+      subProxy :: Proxy subApi
+      subProxy = Proxy
+
+      subConfig :: Config subConfig
+      subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

servant-server/src/Servant/Server/Internal/Config.hs

@@ -0,0 +1,57 @@
+{-# 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
+
+-- | The entire configuration.
+data Config a 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
+
+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
+
+data NamedConfig (name :: Symbol) (subConfig :: [*])
+  = NamedConfig (Config subConfig)
+
+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

servant-server/test/Servant/Server/ErrorSpec.hs

@@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402
 
 errorOrderSpec :: Spec
 errorOrderSpec = describe "HTTP error order"
-           $ with (return $ serve errorOrderApi errorOrderServer) $ do
+           $ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do
   let badContentType  = (hContentType, "text/plain")
       badAccept       = (hAccept, "text/plain")
       badMethod       = methodGet
@@ -89,7 +89,7 @@ prioErrorsApi = Proxy
 prioErrorsSpec :: Spec
 prioErrorsSpec = describe "PrioErrors" $ do
   let server = return
-  with (return $ serve prioErrorsApi server) $ do
+  with (return $ serve prioErrorsApi EmptyConfig server) $ do
     let check (mdescr, method) path (cdescr, ctype, body) resp =
           it fulldescr $
             Test.Hspec.Wai.request method path [(hContentType, ctype)] body
@@ -154,7 +154,7 @@ errorRetryServer
 
 errorRetrySpec :: Spec
 errorRetrySpec = describe "Handler search"
-           $ with (return $ serve errorRetryApi errorRetryServer) $ do
+           $ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do
 
   let jsonCT      = (hContentType, "application/json")
       jsonAccept  = (hAccept, "application/json")
@@ -194,7 +194,7 @@ errorChoiceServer = return 0
 
 errorChoiceSpec :: Spec
 errorChoiceSpec = describe "Multiple handlers return errors"
-                $ with (return $ serve errorChoiceApi errorChoiceServer) $ do
+                $ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do
 
   it "should respond with 404 if no path matches" $ do
     request methodGet "" [] "" `shouldRespondWith` 404

servant-server/test/Servant/Server/Internal/ConfigSpec.hs

@@ -0,0 +1,61 @@
+{-# 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)

servant-server/test/Servant/Server/Internal/EnterSpec.hs

@@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer'
 
 enterSpec :: Spec
 enterSpec = describe "Enter" $ do
-  with (return (serve readerAPI readerServer)) $ do
+  with (return (serve readerAPI EmptyConfig readerServer)) $ do
 
     it "allows running arbitrary monads" $ do
       get "int" `shouldRespondWith` "1797"
       post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
 
-  with (return (serve combinedAPI combinedReaderServer)) $ do
+  with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do
     it "allows combnation of enters" $ do
       get "bool" `shouldRespondWith` "true"

servant-server/test/Servant/Server/UsingConfigSpec.hs

@@ -0,0 +1,125 @@
+{-# 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 =
+  serve (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 = serve (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 = serve (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 = serve (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 = serve (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\""

servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# 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 (HasServer subApi) =>
+  HasServer (ExtractFromConfig :> subApi) 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))
+    where
+      subProxy :: Proxy subApi
+      subProxy = Proxy
+
+      inject config f = f (getConfigEntry config)
+
+data InjectIntoConfig
+
+instance (HasServer subApi) =>
+  HasServer (InjectIntoConfig :> subApi) 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
+    where
+      subProxy :: Proxy subApi
+      subProxy = Proxy
+
+      newConfig = ("injected" :: String) :. config
+
+data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])
+
+instance (HasServer subApi) =>
+  HasServer (NamedConfigWithBirdface name subConfig :> subApi) 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
+    where
+      subProxy :: Proxy subApi
+      subProxy = Proxy
+
+      subConfig :: Config subConfig
+      subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

servant-server/test/Servant/ServerSpec.hs

@@ -48,7 +48,7 @@ import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              StdMethod (..), Verb, addHeader)
 import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Server             (ServantErr (..), Server, err404,
-                                             serve)
+                                             serve, Config(EmptyConfig))
 import           Test.Hspec                 (Spec, context, describe, it,
                                              shouldBe, shouldContain)
 import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
@@ -106,7 +106,7 @@ verbSpec = describe "Servant.API.Verb" $ do
       wrongMethod m = if m == methodPatch then methodPost else methodPatch
       test desc api method (status :: Int) = context desc $
 
-        with (return $ serve api server) $ do
+        with (return $ serve api EmptyConfig server) $ do
 
           -- HEAD and 214/215 need not return bodies
           unless (status `elem` [214, 215] || method == methodHead) $
@@ -181,7 +181,7 @@ captureServer legs = case legs of
 captureSpec :: Spec
 captureSpec = do
   describe "Servant.API.Capture" $ do
-    with (return (serve captureApi captureServer)) $ do
+    with (return (serve captureApi EmptyConfig captureServer)) $ do
 
       it "can capture parts of the 'pathInfo'" $ do
         response <- get "/2"
@@ -192,6 +192,7 @@ captureSpec = do
 
     with (return (serve
         (Proxy :: Proxy (Capture "captured" String :> Raw))
+        EmptyConfig
         (\ "captured" request_ respond ->
             respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "strips the captured path snippet from pathInfo" $ do
@@ -224,8 +225,8 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
 queryParamSpec :: Spec
 queryParamSpec = do
   describe "Servant.API.QueryParam" $ do
-      it "allows to retrieve simple GET parameters" $
+      it "allows retrieving simple GET parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
+        (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
           let params1 = "?name=bob"
           response1 <- Network.Wai.Test.request defaultRequest{
             rawQueryString = params1,
@@ -236,8 +237,8 @@ queryParamSpec = do
               name = "bob"
              }
 
-      it "allows to retrieve lists in GET parameters" $
+      it "allows retrieving lists in GET parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
+        (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
           let params2 = "?names[]=bob&names[]=john"
           response2 <- Network.Wai.Test.request defaultRequest{
             rawQueryString = params2,
@@ -250,8 +251,8 @@ queryParamSpec = do
              }
 
 
-      it "allows to retrieve value-less GET parameters" $
+      it "allows retrieving value-less GET parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
+        (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
           let params3 = "?capitalize"
           response3 <- Network.Wai.Test.request defaultRequest{
             rawQueryString = params3,
@@ -303,7 +304,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
       mkReq method x = Test.Hspec.Wai.request method x
          [(hContentType, "application/json;charset=utf-8")]
 
-  with (return $ serve reqBodyApi server) $ do
+  with (return $ serve reqBodyApi EmptyConfig server) $ do
 
     it "passes the argument to the handler" $ do
       response <- mkReq methodPost "" (encode alice)
@@ -336,13 +337,13 @@ headerSpec = describe "Servant.API.Header" $ do
         expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
         expectsString Nothing  = error "Expected a string"
 
-    with (return (serve headerApi expectsInt)) $ do
+    with (return (serve headerApi EmptyConfig expectsInt)) $ do
         let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
 
         it "passes the header to the handler (Int)" $
             delete' "/" "" `shouldRespondWith` 200
 
-    with (return (serve headerApi expectsString)) $ do
+    with (return (serve headerApi EmptyConfig expectsString)) $ do
         let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
 
         it "passes the header to the handler (String)" $
@@ -366,7 +367,7 @@ rawSpec :: Spec
 rawSpec = do
   describe "Servant.API.Raw" $ do
     it "runs applications" $ do
-      (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
+      (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do
         response <- Network.Wai.Test.request defaultRequest{
           pathInfo = ["foo"]
          }
@@ -374,7 +375,7 @@ rawSpec = do
           simpleBody response `shouldBe` "42"
 
     it "gets the pathInfo modified" $ do
-      (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
+      (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do
         response <- Network.Wai.Test.request defaultRequest{
           pathInfo = ["foo", "bar"]
          }
@@ -408,7 +409,7 @@ alternativeServer =
 alternativeSpec :: Spec
 alternativeSpec = do
   describe "Servant.API.Alternative" $ do
-    with (return $ serve alternativeApi alternativeServer) $ do
+    with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do
 
       it "unions endpoints" $ do
         response <- get "/foo"
@@ -443,7 +444,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
 
 responseHeadersSpec :: Spec
 responseHeadersSpec = describe "ResponseHeaders" $ do
-  with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
+  with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do
 
     let methods = [methodGet, methodPost, methodPut, methodPatch]
 
@@ -509,7 +510,7 @@ miscServ = versionHandler
         hostHandler = return . show
 
 miscCombinatorSpec :: Spec
-miscCombinatorSpec = with (return $ serve miscApi miscServ) $
+miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $
   describe "Misc. combinators for request inspection" $ do
     it "Successfully gets the HTTP version specified in the request" $
       go "/version" "\"HTTP/1.0\""

servant-server/test/Servant/Utils/StaticFilesSpec.hs

@@ -16,7 +16,7 @@ import           Test.Hspec                (Spec, around_, describe, it)
 import           Test.Hspec.Wai            (get, shouldRespondWith, with)
 
 import           Servant.API               ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
-import           Servant.Server            (Server, serve)
+import           Servant.Server            (Server, serve, Config(EmptyConfig))
 import           Servant.ServerSpec        (Person (Person))
 import           Servant.Utils.StaticFiles (serveDirectory)
 
@@ -29,7 +29,7 @@ api :: Proxy Api
 api = Proxy
 
 app :: Application
-app = serve api server
+app = serve api EmptyConfig server
 
 server :: Server Api
 server =

servant/servant.cabal

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

servant/src/Servant/API.hs

@@ -23,6 +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
 
   -- * Actual endpoints, distinguished by HTTP method
   module Servant.API.Verbs,
@@ -88,6 +90,7 @@ import           Servant.API.Verbs           (PostCreated, Delete, DeleteAccepte
                                               PutNoContent, PutNonAuthoritative,
                                               ReflectMethod (reflectMethod),
                                               Verb, StdMethod(..))
+import           Servant.API.WithNamedConfig (WithNamedConfig)
 import           Servant.Utils.Links         (HasLink (..), IsElem, IsElem',
                                               URI (..), safeLink)
 import           Web.HttpApiData             (FromHttpApiData (..),

servant/src/Servant/API/WithNamedConfig.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Servant.API.WithNamedConfig where
+
+import GHC.TypeLits
+
+data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi

stack.yaml

@@ -16,4 +16,5 @@ packages:
 extra-deps:
 - engine-io-wai-1.0.2
 - control-monad-omega-0.3.1
+- should-not-typecheck-2.0.1
 resolver: nightly-2015-10-08