server/config: moved code around

servant-server/src/Servant/Server.hs

@@ -38,6 +38,7 @@ module Servant.Server
 
   -- * Config
   , Config(..)
+  , SubConfig(..)
 
     -- * Default error type
   , ServantErr(..)

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

@@ -473,3 +473,22 @@ pathIsEmpty = go . pathInfo
 
 ct_wildcard :: B.ByteString
 ct_wildcard = "*" <> "/" <> "*" -- Because CPP
+
+-- * configs
+
+instance (HasServer subApi) =>
+  HasServer (SubConfig name subConfig :> subApi) where
+
+  type ServerT (SubConfig name subConfig :> subApi) m =
+    ServerT subApi m
+  type HasCfg (SubConfig name subConfig :> subApi) config =
+    (HasConfigEntry config (SubConfig name subConfig), HasCfg subApi subConfig)
+
+  route Proxy config delayed =
+    route subProxy subConfig delayed
+    where
+      subProxy :: Proxy subApi
+      subProxy = Proxy
+
+      subConfig :: Config subConfig
+      subConfig = descendIntoSubConfig (Proxy :: Proxy name) config

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE GADTs                      #-}
@@ -50,3 +51,15 @@ instance OVERLAPPABLE_
 instance OVERLAPPABLE_
          HasConfigEntry (val ': xs) val where
     getConfigEntry (x :. _) = x
+
+-- * support for subconfigs
+
+data SubConfig (name :: Symbol) (subConfig :: [*])
+  = SubConfig (Config subConfig)
+
+descendIntoSubConfig :: forall config name subConfig .
+  HasConfigEntry config (SubConfig name subConfig) =>
+  Proxy (name :: Symbol) -> Config config -> Config subConfig
+descendIntoSubConfig Proxy config =
+  let SubConfig subConfig = getConfigEntry config :: SubConfig name subConfig
+  in subConfig

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

@@ -25,11 +25,6 @@ spec = do
           x = getConfigEntry config :: Bool
       shouldNotTypecheck x
 
-    it "does not typecheck if tag does not exist" $ do
-      let config = (Tag 'a' :: Tagged "foo" Char) :. EmptyConfig
-          x = getConfigEntry (Proxy :: Proxy "bar") config :: Char
-      shouldNotTypecheck x
-
     context "Show instance" $ do
       let config = 'a' :. True :. EmptyConfig
       it "has a Show instance" $ do
@@ -42,3 +37,25 @@ spec = do
         it "works with operators" $ do
           let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)
           show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"
+
+  describe "descendIntoSubConfig" $ do
+    let config :: Config [Char, SubConfig "sub" '[Char]]
+        config =
+          'a' :.
+          (SubConfig subConfig :: SubConfig "sub" '[Char])
+          :. EmptyConfig
+        subConfig = 'b' :. EmptyConfig
+    it "allows to extract subconfigs" $ do
+      descendIntoSubConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig
+
+    it "allows to extract entries from subconfigs" $ do
+      getConfigEntry (descendIntoSubConfig (Proxy :: Proxy "sub") config :: Config '[Char])
+        `shouldBe` 'b'
+
+    it "does not typecheck if subConfig has the wrong type" $ do
+      let x = descendIntoSubConfig (Proxy :: Proxy "sub") config :: Config '[Int]
+      shouldNotTypecheck (show x)
+
+    it "does not typecheck if subConfig with that name doesn't exist" $ do
+      let x = descendIntoSubConfig (Proxy :: Proxy "foo") config :: Config '[Char]
+      shouldNotTypecheck (show x)

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

@@ -25,7 +25,8 @@ oneEntryApp :: Application
 oneEntryApp =
   serve (Proxy :: Proxy OneEntryAPI) config testServer
   where
-    config = ("configEntry" :: String) :. EmptyConfig
+    config :: Config '[String]
+    config = "configEntry" :. EmptyConfig
 
 type OneEntryTwiceAPI =
   "foo" :> ExtractFromConfig :> Get '[JSON] String :<|>
@@ -36,7 +37,8 @@ oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $
   testServer :<|>
   testServer
   where
-    config = ("configEntryTwice" :: String) :. EmptyConfig
+    config :: Config '[String]
+    config = "configEntryTwice" :. EmptyConfig
 
 -- * tests
 
@@ -89,10 +91,10 @@ subConfigApp = serve (Proxy :: Proxy SubConfigAPI) config $
   testServer :<|>
   testServer
   where
-    config :: Config '[String, (Tagged "sub" (Config '[String]))]
+    config :: Config '[String, (SubConfig "sub" '[String])]
     config =
-      ("firstEntry" :: String) :.
-      (Tag (("secondEntry" :: String) :. EmptyConfig)) :.
+      "firstEntry" :.
+      (SubConfig ("secondEntry" :. EmptyConfig)) :.
       EmptyConfig
 
 spec3 :: Spec

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

@@ -55,27 +55,3 @@ instance (HasServer subApi) =>
       subProxy = Proxy
 
       newConfig = ("injected" :: String) :. config
-
-data SubConfig (name :: Symbol) (subConfig :: [*])
-
-newtype Tagged tag a = Tag a
-  deriving (Show, Eq)
-
-instance (HasServer subApi) =>
-  HasServer (SubConfig name subConfig :> subApi) where
-
-  type ServerT (SubConfig name subConfig :> subApi) m =
-    ServerT subApi m
-  type HasCfg (SubConfig name subConfig :> subApi) config =
-    (HasConfigEntry config (Tagged name (Config subConfig)), HasCfg subApi subConfig)
-
-  route Proxy config delayed =
-    route subProxy subConfig delayed
-    where
-      subProxy :: Proxy subApi
-      subProxy = Proxy
-
-      subConfig :: Config subConfig
-      subConfig =
-        let Tag x = getConfigEntry config :: Tagged name (Config subConfig)
-        in x