From d8db0fa7798a44c110e6d8c5aba5f85a774d5865 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?S=C3=B6nke=20Hahn?= <soenkehahn@gmail.com>
Date: Wed, 13 Jan 2016 21:22:01 +0100
Subject: [PATCH] server/config: add an experimental `Descend` combinator

---
 .../test/Servant/Server/UsingConfigSpec.hs     | 18 ++++++++++++++++++
 .../Server/UsingConfigSpec/TestCombinators.hs  | 17 +++++++++++++++++
 2 files changed, 35 insertions(+)

diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs
index dec26b1f..e934ab83 100644
--- a/servant-server/test/Servant/Server/UsingConfigSpec.hs
+++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs
@@ -18,6 +18,7 @@ spec = do
   spec1
   spec2
   spec3
+  spec4
 
 -- * API
 
@@ -105,3 +106,20 @@ spec3 = do
     it "allows retrieving different ConfigEntries for the same combinator" $ do
       get "/foo" `shouldRespondWith` "\"firstEntry\""
       get "/bar" `shouldRespondWith` "\"secondEntry\""
+
+type DescendAPI =
+  Descend "sub" '[String] (
+    ExtractFromConfig :> Get '[JSON] String)
+
+descendApp :: Application
+descendApp = serve (Proxy :: Proxy DescendAPI) config return
+  where
+    config :: Config '[SubConfig "sub" '[String]]
+    config = SubConfig ("descend" :. EmptyConfig) :. EmptyConfig
+
+spec4 :: Spec
+spec4 = do
+  with (return descendApp) $ do
+    describe "Descend" $ do
+      it "allows to descend into a subconfig for a given api" $ do
+        get "/" `shouldRespondWith` "\"descend\""
diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs
index 31fd0b1f..f17fcb1f 100644
--- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs
+++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs
@@ -54,3 +54,20 @@ instance (HasServer subApi) =>
       subProxy = Proxy
 
       newConfig = ("injected" :: String) :. config
+
+data Descend (name :: Symbol) (subConfig :: [*]) subApi
+
+instance HasServer subApi => HasServer (Descend name subConfig subApi) where
+  type ServerT (Descend name subConfig subApi) m =
+    ServerT subApi m
+  type HasCfg (Descend 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