Merge commit '8ecc3f07064a3a627b8e49fb182789c82cd9c5d7' into jkarni/config

.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:

CONTRIBUTING.md

@@ -77,3 +77,10 @@ the `news` label if you make a new package so we can know about it!
 We are currently moving to a more aggresive release policy, so that you can get
 what you contribute from Hackage fairly soon. However, note that prior to major
 releases it may take some time in between releases.
+
+## Reporting security issues
+
+Please email haskell-servant-maintainers AT googlegroups DOT com. This group is
+private, and accessible only to known maintainers. We will then discuss how to
+proceed. Please do not make the issue public before we inform you that we have
+a patch ready.

servant-client/test/Servant/ClientSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                    #-}
+{-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE FlexibleContexts       #-}

servant-docs/src/Servant/Docs/Internal.hs

@@ -735,6 +735,15 @@ instance OVERLAPPING_
           status = fromInteger $ natVal (Proxy :: Proxy status)
           p = Proxy :: Proxy a
 
+instance (KnownSymbol sym, HasDocs sublayout)
+      => HasDocs (Header sym a :> sublayout) where
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint, action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          action' = over headers (|> headername) action
+          headername = T.pack $ symbolVal (Proxy :: Proxy sym)
+
 instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
       => HasDocs (QueryParam sym a :> sublayout) where
 

servant-docs/test/Servant/DocsSpec.hs

@@ -63,6 +63,7 @@ spec = describe "Servant.Docs" $ do
          , ("zwei, kaks, kaks",(TT2,UT2,UT2))
          ]
 
+
  where
    tests md = do
     it "mentions supported content-types" $ do
@@ -76,11 +77,15 @@ spec = describe "Servant.Docs" $ do
       md `shouldContain` "POST"
       md `shouldContain` "GET"
 
+    it "mentions headers" $ do
+      md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
+
     it "contains response samples" $
       md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
     it "contains request body samples" $
       md `shouldContain` "17"
 
+
 -- * APIs
 
 data Datatype1 = Datatype1 { dt1field1 :: String
@@ -103,6 +108,7 @@ instance MimeRender PlainText Int where
 
 type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
            :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
+           :<|> Header "X-Test" Int :> Put '[JSON] Int
 
 data TT = TT1 | TT2 deriving (Show, Eq)
 data UT = UT1 | UT2 deriving (Show, Eq)

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-mock/servant-mock.cabal

@@ -18,8 +18,7 @@ cabal-version:       >=1.10
 
 flag example
   description: Build the example too
-  manual: True
+  default: True
-  default: False
 
 library
   exposed-modules:

servant-mock/src/Servant/Mock.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}

servant-server/servant-server.cabal

@@ -99,11 +99,13 @@ test-suite spec
   hs-source-dirs: test
   main-is: Spec.hs
   other-modules:
-      Servant.Server.Internal.EnterSpec
-      Servant.Server.Internal.ConfigSpec
-      Servant.ServerSpec
-      Servant.Utils.StaticFilesSpec
       Servant.Server.ErrorSpec
+      Servant.Server.Internal.ConfigSpec
+      Servant.Server.Internal.EnterSpec
+      Servant.ServerSpec
+      Servant.Server.UsingConfigSpec
+      Servant.Server.UsingConfigSpec.TestCombinators
+      Servant.Utils.StaticFilesSpec
   build-depends:
       base == 4.*
     , aeson

servant-server/src/Servant/Server.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
@@ -35,11 +36,6 @@ module Servant.Server
   , generalizeNat
   , tweakResponse
 
-  -- * Config
-  , ConfigEntry(..)
-  , Config(..)
-  , (.:.)
-
   -- * General Authentication
   , AuthHandler(unAuthHandler)
   , AuthReturnType
@@ -49,6 +45,10 @@ module Servant.Server
   , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
   , BasicAuthResult(..)
 
+  -- * Config
+  , Config(..)
+  , NamedConfig(..)
+
     -- * Default error type
   , ServantErr(..)
     -- ** 3XX
@@ -77,7 +77,7 @@ module Servant.Server
   , err415
   , err416
   , err417
-   -- * 5XX
+   -- ** 5XX
   , err500
   , err501
   , err502
@@ -110,18 +110,18 @@ import           Servant.Server.Internal.Enter
 -- > myApi :: Proxy MyApi
 -- > myApi = Proxy
 -- >
--- > cfg :: Config '[]
+-- > config :: Config '[]
--- > cfg = EmptyConfig
+-- > config = EmptyConfig
 -- >
 -- > app :: Application
--- > app = serve myApi cfg server
+-- > app = serve myApi config server
 -- >
 -- > main :: IO ()
 -- > main = Network.Wai.Handler.Warp.run 8080 app
 --
-serve :: (HasCfg layout a, HasServer layout)
+serve :: (HasConfig layout a, HasServer layout)
     => Proxy layout -> Config a -> Server layout -> Application
-serve p cfg server = toApplication (runRouter (route p cfg d))
+serve p config server = toApplication (runRouter (route p config d))
   where
     d = Delayed r 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          #-}
@@ -53,7 +54,8 @@ import           Servant.API                 ((:<|>) (..), (:>), AuthProtect, Ba
                                               Verb, ReflectMethod(reflectMethod),
                                               IsSecure(..), Header,
                                               QueryFlag, QueryParam, QueryParams,
-                                              Raw, RemoteHost, ReqBody, Vault)
+                                              Raw, RemoteHost, ReqBody, Vault,
+                                              WithNamedConfig)
 import           Servant.API.ContentTypes    (AcceptHeader (..),
                                               AllCTRender (..),
                                               AllCTUnrender (..),
@@ -71,9 +73,9 @@ import           Servant.Server.Internal.ServantErr
 
 class HasServer layout where
   type ServerT layout (m :: * -> *) :: *
-  type HasCfg layout (c :: [*]) :: Constraint
+  type HasConfig layout (c :: [*]) :: Constraint
 
-  route :: HasCfg layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
+  route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
 
 type Server layout = ServerT layout (ExceptT ServantErr IO)
 
@@ -93,10 +95,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 HasCfg (a :<|> b) c = (HasCfg a c, HasCfg b c)
+  type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c)
 
-  route Proxy cfg server = choice (route pa cfg ((\ (a :<|> _) -> a) <$> server))
+  route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
-                                  (route pb cfg ((\ (_ :<|> b) -> b) <$> server))
+                                     (route pb config ((\ (_ :<|> b) -> b) <$> server))
     where pa = Proxy :: Proxy a
           pb = Proxy :: Proxy b
 
@@ -125,12 +127,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (Capture capture a :> sublayout) m =
      a -> ServerT sublayout m
-  type HasCfg (Capture capture a :> sublayout) c = (HasCfg sublayout c)
+  type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)
 
-  route Proxy cfg d =
+  route Proxy config d =
     DynamicRouter $ \ first ->
         route (Proxy :: Proxy sublayout)
-              cfg
+              config
               (addCapture d $ case captured captureProxy first of
                  Nothing -> return $ Fail err404
                  Just v  -> return $ Route v
@@ -202,7 +204,7 @@ instance OVERLAPPABLE_
          ) => HasServer (Verb method status ctypes a) where
 
   type ServerT (Verb method status ctypes a) m = m a
-  type HasCfg (Verb method status ctypes a) c = ()
+  type HasConfig (Verb method status ctypes a) c = ()
 
   route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
     where method = reflectMethod (Proxy :: Proxy method)
@@ -214,7 +216,7 @@ 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 HasCfg (Verb method status ctypes (Headers h a)) c = ()
+  type HasConfig (Verb method status ctypes (Headers h a)) c = ()
 
   route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
     where method = reflectMethod (Proxy :: Proxy method)
@@ -245,11 +247,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (Header sym a :> sublayout) m =
     Maybe a -> ServerT sublayout m
-  type HasCfg (Header sym a :> sublayout) c = HasCfg sublayout c
+  type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy cfg subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
     let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
-    in  route (Proxy :: Proxy sublayout) cfg (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,
@@ -278,9 +280,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (QueryParam sym a :> sublayout) m =
     Maybe a -> ServerT sublayout m
-  type HasCfg (QueryParam sym a :> sublayout) c = HasCfg sublayout c
+  type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy cfg subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
     let querytext = parseQueryText $ rawQueryString request
         param =
           case lookup paramname querytext of
@@ -288,7 +290,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) cfg (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,
@@ -315,16 +317,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   type ServerT (QueryParams sym a :> sublayout) m =
     [a] -> ServerT sublayout m
-  type HasCfg (QueryParams sym a :> sublayout) c = HasCfg sublayout c
+  type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy cfg 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) cfg (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
@@ -347,15 +349,15 @@ instance (KnownSymbol sym, HasServer sublayout)
 
   type ServerT (QueryFlag sym :> sublayout) m =
     Bool -> ServerT sublayout m
-  type HasCfg (QueryFlag sym :> sublayout) c = HasCfg sublayout c
+  type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c
 
-  route Proxy cfg 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) cfg (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
@@ -371,7 +373,7 @@ instance (KnownSymbol sym, HasServer sublayout)
 instance HasServer Raw where
 
   type ServerT Raw m = Application
-  type HasCfg Raw c = ()
+  type HasConfig Raw c = ()
 
   route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
     r <- runDelayed rawApplication
@@ -406,10 +408,10 @@ instance ( AllCTUnrender list a, HasServer sublayout
 
   type ServerT (ReqBody list a :> sublayout) m =
     a -> ServerT sublayout m
-  type HasCfg (ReqBody list a :> sublayout) c = HasCfg sublayout c
+  type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c
 
-  route Proxy cfg subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy sublayout) cfg (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
@@ -430,67 +432,67 @@ instance ( AllCTUnrender list a, HasServer sublayout
 instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
 
   type ServerT (path :> sublayout) m = ServerT sublayout m
-  type HasCfg (path :> sublayout) c = HasCfg sublayout c
+  type HasConfig (path :> sublayout) c = HasConfig sublayout c
 
-  route Proxy cfg subserver = StaticRouter $
+  route Proxy config subserver = StaticRouter $
     M.singleton (cs (symbolVal proxyPath))
-                (route (Proxy :: Proxy sublayout) cfg 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 HasCfg (RemoteHost :> api) c = HasCfg api c
+  type HasConfig (RemoteHost :> api) c = HasConfig api c
 
-  route Proxy cfg subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) cfg (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 HasCfg (IsSecure :> api) c = HasCfg api c
+  type HasConfig (IsSecure :> api) c = HasConfig api c
 
-  route Proxy cfg subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) cfg (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 HasCfg (Vault :> api) c = HasCfg api c
+  type HasConfig (Vault :> api) c = HasConfig api c
 
-  route Proxy cfg subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) cfg (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 HasCfg (HttpVersion :> api) c = HasCfg api c
+  type HasConfig (HttpVersion :> api) c = HasConfig api c
 
-  route Proxy cfg subserver = WithRequest $ \req ->
+  route Proxy config subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req)
+    route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
 
 -- | Basic Authentication
 instance (KnownSymbol realm, HasServer api)
     => HasServer (BasicAuth tag realm usr :> api) where
   type ServerT (BasicAuth tag realm usr :> api) m = usr -> ServerT api m
-  type HasCfg (BasicAuth tag realm usr :> api) c
+  type HasConfig (BasicAuth tag realm usr :> api) c
-    = (HasConfigEntry c tag (BasicAuthCheck usr), HasCfg api c)
+    = (HasConfigEntry c (BasicAuthCheck usr), HasConfig api c)
 
-  route Proxy cfg subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy api) cfg (subserver `addAuthCheck` authCheck request)
+    route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
     where
        realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
-       baCfg = getConfigEntry (Proxy :: Proxy tag) cfg
+       basicAuthConfig = getConfigEntry config
-       authCheck req = runBasicAuth req realm baCfg
+       authCheck req = runBasicAuth req realm basicAuthConfig
 
 -- | General Authentication
 instance HasServer api => HasServer (AuthProtect tag :> api) where
   type ServerT (AuthProtect tag :> api) m = AuthReturnType (AuthProtect tag) -> ServerT api m
-  type HasCfg (AuthProtect tag :> api) c
+  type HasConfig (AuthProtect tag :> api) c
-    = (HasConfigEntry c tag (AuthHandler Request (AuthReturnType (AuthProtect tag))), HasCfg api c)
+    = (HasConfigEntry c (AuthHandler Request (AuthReturnType (AuthProtect tag))), HasConfig api c)
 
-  route Proxy cfg subserver = WithRequest $ \ request ->
+  route Proxy config subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy api) cfg (subserver `addAuthCheck` authCheck request)
+    route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
       where
-        authHandler = unAuthHandler (getConfigEntry (Proxy :: Proxy tag) cfg)
+        authHandler = unAuthHandler (getConfigEntry config)
         authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
 
 pathIsEmpty :: Request -> Bool
@@ -501,3 +503,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

@@ -1,62 +1,57 @@
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE DeriveFunctor              #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE PolyKinds                  #-}
 {-# LANGUAGE TypeOperators              #-}
-{-# LANGUAGE UndecidableInstances       #-}
 
 #include "overlapping-compat.h"
 
 module Servant.Server.Internal.Config where
 
-import Control.DeepSeq (NFData)
+import           Data.Proxy
-import GHC.Generics (Generic)
+import           GHC.TypeLits
-import Data.Typeable (Typeable)
-
--- | A single entry in the configuration. The first parameter is phantom, and
--- is used to lookup a @ConfigEntry@ in a @Config@.
-newtype ConfigEntry tag a = ConfigEntry { unConfigEntry :: a }
-  deriving ( Eq, Show, Read, Enum, Integral, Fractional, Generic, Typeable
-           , Num, Ord, Real, Functor, Foldable, Traversable, NFData)
 
 -- | The entire configuration.
 data Config a where
     EmptyConfig :: Config '[]
-    ConsConfig :: x -> Config xs -> Config (x ': xs)
+    (:.) :: x -> Config xs -> Config (x ': xs)
+infixr 5 :.
 
 instance Show (Config '[]) where
   show EmptyConfig = "EmptyConfig"
-instance (Show a, Show (Config as)) => Show (Config (ConfigEntry tag a ': as)) where
+instance (Show a, Show (Config as)) => Show (Config (a ': as)) where
-  showsPrec outerPrecedence (ConsConfig (ConfigEntry a) as) =
+  showsPrec outerPrecedence (a :. as) =
     showParen (outerPrecedence > 5) $
-      shows a . showString " .:. " . shows as
+      shows a . showString " :. " . shows as
 
 instance Eq (Config '[]) where
     _ == _ = True
 instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
-    ConsConfig x1 y1 == ConsConfig x2 y2 = x1 == x2 && y1 == y2
+    x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
 
-(.:.) :: x -> Config xs -> Config (ConfigEntry tag x ': xs)
+class HasConfigEntry (config :: [*]) (val :: *) where
-e .:. cfg = ConsConfig (ConfigEntry e) cfg
+    getConfigEntry :: Config config -> val
-infixr 5 .:.
-
-class HasConfigEntry (cfg :: [*]) (a :: k) (val :: *) | cfg a -> val where
-    getConfigEntry :: proxy a -> Config cfg -> val
 
 instance OVERLAPPABLE_
-         HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where
+         HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
-    getConfigEntry p (ConsConfig _ xs) = getConfigEntry p xs
+    getConfigEntry (_ :. xs) = getConfigEntry xs
 
-instance OVERLAPPABLE_
+instance OVERLAPPING_
-         HasConfigEntry (ConfigEntry tag val ': xs) tag val where
+         HasConfigEntry (val ': xs) val where
-    getConfigEntry _ (ConsConfig x _) = unConfigEntry x
+    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/Internal/ConfigSpec.hs

@@ -11,42 +11,51 @@ import           Servant.Server.Internal.Config
 
 spec :: Spec
 spec = do
-  getConfigEntrySpec
+  describe "getConfigEntry" $ do
+    it "gets the config if a matching one exists" $ do
+      let config = 'a' :. EmptyConfig
+      getConfigEntry config `shouldBe` 'a'
 
-getConfigEntrySpec :: Spec
+    it "gets the first matching config" $ do
-getConfigEntrySpec = describe "getConfigEntry" $ do
+      let config = 'a' :. 'b' :. EmptyConfig
+      getConfigEntry config `shouldBe` 'a'
 
-  let cfg1 = 0 .:. EmptyConfig :: Config '[ConfigEntry "a" Int]
+    it "does not typecheck if type does not exist" $ do
-      cfg2 = 1 .:. cfg1 :: Config '[ConfigEntry "a" Int, ConfigEntry "a" Int]
+      let config = 'a' :. EmptyConfig
+          x = getConfigEntry config :: Bool
+      shouldNotTypecheck x
 
-  it "gets the config if a matching one exists" $ do
+    context "Show instance" $ do
+      let config = 'a' :. True :. EmptyConfig
+      it "has a Show instance" $ do
+        show config `shouldBe` "'a' :. True :. EmptyConfig"
 
-    getConfigEntry (Proxy :: Proxy "a") cfg1 `shouldBe` 0
+      context "bracketing" $ do
+        it "works" $ do
+          show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)"
 
-  it "gets the first matching config" $ do
+        it "works with operators" $ do
+          let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)
+          show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"
 
-    getConfigEntry (Proxy :: Proxy "a") cfg2 `shouldBe` 1
+  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 to distinguish between different config entries with the same type by tag" $ do
+    it "allows extracting entries from subconfigs" $ do
-    let cfg = 'a' .:. 'b' .:. EmptyConfig :: Config '[ConfigEntry 1 Char, ConfigEntry 2 Char]
+      getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char])
-    getConfigEntry (Proxy :: Proxy 1) cfg `shouldBe` 'a'
+        `shouldBe` 'b'
 
-  context "Show instance" $ do
+    it "does not typecheck if subConfig has the wrong type" $ do
-    let cfg = 1 .:. 2 .:. EmptyConfig
+      let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int]
-    it "has a Show instance" $ do
+      shouldNotTypecheck (show x)
-      show cfg `shouldBe` "1 .:. 2 .:. EmptyConfig"
 
-    it "bracketing works" $ do
+    it "does not typecheck if subConfig with that name doesn't exist" $ do
-      show (Just cfg) `shouldBe` "Just (1 .:. 2 .:. EmptyConfig)"
+      let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char]
-
+      shouldNotTypecheck (show x)
-    it "bracketing works with operators" $ do
-      let cfg = (1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)
-      show cfg `shouldBe` "(1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)"
-
-  it "does not typecheck if key does not exist" $ do
-    let x = getConfigEntry (Proxy :: Proxy "b") cfg1 :: Int
-    shouldNotTypecheck x
-
-  it "does not typecheck if key maps to a different type" $ do
-    let x = getConfigEntry (Proxy :: Proxy "a") cfg1 :: String
-    shouldNotTypecheck x

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,10 +48,10 @@ import           Servant.API                ((:<|>) (..), (:>), AuthProtect, Bas
                                              QueryFlag, QueryParam, QueryParams,
                                              Raw, RemoteHost, ReqBody,
                                              StdMethod (..), Verb, addHeader)
-import           Servant.Server             ((.:.), AuthHandler, AuthReturnType,
+import           Servant.Server             (AuthHandler, AuthReturnType,
                                              BasicAuthCheck (BasicAuthCheck),
                                              BasicAuthResult (Authorized, Unauthorized),
-                                             Config (EmptyConfig), ConfigEntry, ServantErr (..),
+                                             Config ((:.), EmptyConfig), ServantErr (..),
                                              mkAuthHandler, Server, err401, err404, serve)
 import           Test.Hspec                 (Spec, context, describe, it,
                                              shouldBe, shouldContain)
@@ -226,7 +226,7 @@ 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 EmptyConfig qpServer) $ do
           let params1 = "?name=bob"
           response1 <- Network.Wai.Test.request defaultRequest{
@@ -238,7 +238,7 @@ queryParamSpec = do
               name = "bob"
              }
 
-      it "allows to retrieve lists in GET parameters" $
+      it "allows retrieving lists in GET parameters" $
         (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
           let params2 = "?names[]=bob&names[]=john"
           response2 <- Network.Wai.Test.request defaultRequest{
@@ -252,7 +252,7 @@ queryParamSpec = do
              }
 
 
-      it "allows to retrieve value-less GET parameters" $
+      it "allows retrieving value-less GET parameters" $
         (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
           let params3 = "?capitalize"
           response3 <- Network.Wai.Test.request defaultRequest{
@@ -339,13 +339,13 @@ headerSpec = describe "Servant.API.Header" $ do
         expectsString Nothing  = error "Expected a string"
 
     with (return (serve headerApi EmptyConfig expectsInt)) $ do
-        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
+        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 EmptyConfig expectsString)) $ do
-        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
+        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
 
         it "passes the header to the handler (String)" $
             delete' "/" "" `shouldRespondWith` 200
@@ -537,8 +537,8 @@ authServer = const (return jerry) :<|> const (return tweety)
 
 type instance AuthReturnType (AuthProtect "auth") = ()
 
-authConfig :: Config '[ ConfigEntry "basic" (BasicAuthCheck ())
+authConfig :: Config '[ BasicAuthCheck ()
-                      , ConfigEntry "auth"  (AuthHandler Request ())
+                      , AuthHandler Request ()
                       ]
 authConfig =
   let basicHandler = BasicAuthCheck $ (\usr pass ->
@@ -551,7 +551,7 @@ authConfig =
         then return ()
         else throwE err401
         )
-  in basicHandler .:. mkAuthHandler authHandler .:. EmptyConfig
+  in basicHandler :. mkAuthHandler authHandler :. EmptyConfig
 
 authSpec :: Spec
 authSpec = do

servant/.ghci

@@ -0,0 +1 @@
+:set -isrc -itest -Iinclude -optP-include -optPdist/build/autogen/cabal_macros.h

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,
@@ -92,6 +94,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