diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs index 65ce56e9..c78f9901 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -5,6 +5,7 @@ module Servant.Server.UsingConfigSpec where +import Control.Monad.Trans.Except import Network.Wai import Test.Hspec (Spec, describe, it) import Test.Hspec.Wai @@ -17,7 +18,7 @@ import Servant.Server.UsingConfigSpec.TestCombinators type OneEntryAPI = ExtractFromConfig () :> Get '[JSON] String -testServer :: Server OneEntryAPI +testServer :: String -> ExceptT ServantErr IO String testServer s = return s oneEntryApp :: Application @@ -94,3 +95,27 @@ spec2 = do it "allows to inject tagged config entries" $ do get "/tagged" `shouldRespondWith` "\"tagged: injected\"" + + spec3 + +type SubConfigAPI = + "foo" :> ExtractFromConfig () :> Get '[JSON] String :<|> + SubConfig "sub" '[Tagged () String] :> + "bar" :> ExtractFromConfig () :> Get '[JSON] String + +subConfigApp :: Application +subConfigApp = serve (Proxy :: Proxy SubConfigAPI) config $ + testServer :<|> + testServer + where + config :: Config '[Tagged () String, Tagged () (Tagged "sub" (Config '[Tagged () String]))] + config = + ("firstEntry" :: String) .:. + (Tag (("secondEntry") .:. EmptyConfig)) .:. + EmptyConfig + +spec3 = do + with (return subConfigApp) $ do + it "allows to retrieve different ConfigEntries for the same combinator" $ do + get "/foo" `shouldRespondWith` "\"firstEntry\"" + get "/bar" `shouldRespondWith` "\"secondEntry\"" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs index 006036d2..2b0c545d 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -55,3 +55,24 @@ instance (HasServer subApi) => subProxy = Proxy newConfig = (Tag "injected" :: Tagged tag String) :. config + +data SubConfig (name :: Symbol) (subConfig :: [*]) + +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 (Proxy :: Proxy ()) config) :: Tagged name (Config subConfig) + in x