eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

server/config: allow injecting tagged config entries

Browse source
This commit is contained in:
Sönke Hahn 2016-01-13 15:40:40 +01:00
parent d5441f4871
commit 5e7d1c1081
2 changed files with 31 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
servant-server/test/Servant/Server/UsingConfigSpec.hs
View file

@ -73,12 +73,15 @@ spec = do
spec2 spec2
type InjectAPI = type InjectAPI =
InjectIntoConfig :> "somePath" :> ExtractFromConfig () :> InjectIntoConfig () :> "untagged" :> ExtractFromConfig () :>
Get '[JSON] String :<|>
InjectIntoConfig "tag" :> "tagged" :> ExtractFromConfig "tag" :>
Get '[JSON] String Get '[JSON] String
injectApp :: Application injectApp :: Application
injectApp = serve (Proxy :: Proxy InjectAPI) config $ injectApp = serve (Proxy :: Proxy InjectAPI) config $
\ s -> return s (\ s -> return s) :<|>
(\ s -> return ("tagged: " ++ s))
where where
config = EmptyConfig config = EmptyConfig
@ -87,4 +90,7 @@ spec2 = do
with (return injectApp) $ do with (return injectApp) $ do
describe "inserting config entries with custom combinators" $ do describe "inserting config entries with custom combinators" $ do
it "allows to inject config entries" $ do it "allows to inject config entries" $ do
get "/somePath" `shouldRespondWith` "\"injected\"" get "/untagged" `shouldRespondWith` "\"injected\""
it "allows to inject tagged config entries" $ do
get "/tagged" `shouldRespondWith` "\"tagged: injected\""

26
servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs
View file

@ -13,6 +13,8 @@
-- the config. -- the config.
module Servant.Server.UsingConfigSpec.TestCombinators where module Servant.Server.UsingConfigSpec.TestCombinators where
import GHC.TypeLits
import Servant import Servant
import Servant.Server.Internal.Config import Servant.Server.Internal.Config
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
@ -36,14 +38,30 @@ instance forall subApi (c :: [*]) tag .
inject config f = f (getConfigEntry (Proxy :: Proxy tag) config) inject config f = f (getConfigEntry (Proxy :: Proxy tag) config)
data InjectIntoConfig data InjectIntoConfig (tag :: k)
instance (HasServer subApi) => instance (HasServer subApi) =>
HasServer (InjectIntoConfig :> subApi) where HasServer (InjectIntoConfig (tag :: Symbol) :> subApi) where
type ServerT (InjectIntoConfig :> subApi) m = type ServerT (InjectIntoConfig tag :> subApi) m =
ServerT subApi m ServerT subApi m
type HasCfg (InjectIntoConfig :> subApi) c = type HasCfg (InjectIntoConfig tag :> subApi) c =
(HasCfg subApi (Tagged tag String ': c))
route Proxy config delayed =
route subProxy newConfig delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
newConfig = (Tag "injected" :: Tagged tag String) :. config
instance (HasServer subApi) =>
HasServer (InjectIntoConfig () :> subApi) where
type ServerT (InjectIntoConfig () :> subApi) m =
ServerT subApi m
type HasCfg (InjectIntoConfig () :> subApi) c =
(HasCfg subApi (String ': c)) (HasCfg subApi (String ': c))
route Proxy config delayed = route Proxy config delayed =