From 7bf389090b99ef6e86ee76fe0f713566af6c757c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 14 Jan 2016 23:32:25 +0100 Subject: [PATCH] server/config: only have one combinator exposed (and renamings) --- servant-server/src/Servant/Server.hs | 3 +- servant-server/src/Servant/Server/Internal.hs | 14 ++++----- .../src/Servant/Server/Internal/Config.hs | 14 ++++----- .../Servant/Server/Internal/ConfigSpec.hs | 14 ++++----- .../test/Servant/Server/UsingConfigSpec.hs | 30 +++++++++---------- .../Server/UsingConfigSpec/TestCombinators.hs | 14 +++++---- 6 files changed, 46 insertions(+), 43 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index aae5de83..22649bd2 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -38,7 +38,8 @@ module Servant.Server -- * Config , Config(..) - , SubConfig(..) + , NamedConfig(..) + , WithNamedConfig(..) -- * Default error type , ServantErr(..) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 864ca819..943cc90e 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -33,7 +33,7 @@ import Data.String.Conversions (cs, (<>)) import Data.Text (Text) import Data.Typeable import GHC.Exts (Constraint) -import GHC.TypeLits (KnownNat, KnownSymbol, natVal, +import GHC.TypeLits (Symbol, KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Socket (SockAddr) @@ -476,13 +476,13 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP -- * configs -instance (HasServer subApi) => - HasServer (SubConfig name subConfig :> subApi) where +data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi - type ServerT (SubConfig name subConfig :> subApi) m = +instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where + type ServerT (WithNamedConfig name subConfig subApi) m = ServerT subApi m - type HasConfig (SubConfig name subConfig :> subApi) config = - (HasConfigEntry config (SubConfig name subConfig), HasConfig subApi subConfig) + type HasConfig (WithNamedConfig name subConfig subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) route Proxy config delayed = route subProxy subConfig delayed @@ -491,4 +491,4 @@ instance (HasServer subApi) => subProxy = Proxy subConfig :: Config subConfig - subConfig = descendIntoSubConfig (Proxy :: Proxy name) config + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs index 90d41555..e710de4b 100644 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -44,14 +44,14 @@ instance OVERLAPPING_ HasConfigEntry (val ': xs) val where getConfigEntry (x :. _) = x --- * support for subconfigs +-- * support for named subconfigs -data SubConfig (name :: Symbol) (subConfig :: [*]) - = SubConfig (Config subConfig) +data NamedConfig (name :: Symbol) (subConfig :: [*]) + = NamedConfig (Config subConfig) -descendIntoSubConfig :: forall config name subConfig . - HasConfigEntry config (SubConfig name subConfig) => +descendIntoNamedConfig :: forall config name subConfig . + HasConfigEntry config (NamedConfig name subConfig) => Proxy (name :: Symbol) -> Config config -> Config subConfig -descendIntoSubConfig Proxy config = - let SubConfig subConfig = getConfigEntry config :: SubConfig name subConfig +descendIntoNamedConfig Proxy config = + let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig in subConfig diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs index 51f67d07..c754d839 100644 --- a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs +++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs @@ -38,24 +38,24 @@ spec = 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]] + describe "descendIntoNamedConfig" $ do + let config :: Config [Char, NamedConfig "sub" '[Char]] config = 'a' :. - (SubConfig subConfig :: SubConfig "sub" '[Char]) + (NamedConfig subConfig :: NamedConfig "sub" '[Char]) :. EmptyConfig subConfig = 'b' :. EmptyConfig it "allows to extract subconfigs" $ do - descendIntoSubConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig + descendIntoNamedConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig it "allows to extract entries from subconfigs" $ do - getConfigEntry (descendIntoSubConfig (Proxy :: Proxy "sub") config :: Config '[Char]) + getConfigEntry (descendIntoNamedConfig (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] + let x = descendIntoNamedConfig (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] + let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char] shouldNotTypecheck (show x) diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs index e934ab83..ad26be93 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -84,42 +84,42 @@ spec2 = do it "allows to inject tagged config entries" $ do get "/tagged" `shouldRespondWith` "\"tagged: injected\"" -type SubConfigAPI = +type WithBirdfaceAPI = "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> - SubConfig "sub" '[String] :> + NamedConfigWithBirdface "sub" '[String] :> "bar" :> ExtractFromConfig :> Get '[JSON] String -subConfigApp :: Application -subConfigApp = serve (Proxy :: Proxy SubConfigAPI) config $ +withBirdfaceApp :: Application +withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $ testServer :<|> testServer where - config :: Config '[String, (SubConfig "sub" '[String])] + config :: Config '[String, (NamedConfig "sub" '[String])] config = "firstEntry" :. - (SubConfig ("secondEntry" :. EmptyConfig)) :. + (NamedConfig ("secondEntry" :. EmptyConfig)) :. EmptyConfig spec3 :: Spec spec3 = do - with (return subConfigApp) $ do + with (return withBirdfaceApp) $ do it "allows retrieving different ConfigEntries for the same combinator" $ do get "/foo" `shouldRespondWith` "\"firstEntry\"" get "/bar" `shouldRespondWith` "\"secondEntry\"" -type DescendAPI = - Descend "sub" '[String] ( +type NamedConfigAPI = + WithNamedConfig "sub" '[String] ( ExtractFromConfig :> Get '[JSON] String) -descendApp :: Application -descendApp = serve (Proxy :: Proxy DescendAPI) config return +namedConfigApp :: Application +namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return where - config :: Config '[SubConfig "sub" '[String]] - config = SubConfig ("descend" :. EmptyConfig) :. EmptyConfig + config :: Config '[NamedConfig "sub" '[String]] + config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig spec4 :: Spec spec4 = do - with (return descendApp) $ do - describe "Descend" $ do + with (return namedConfigApp) $ do + describe "WithNamedConfig" $ 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 5766533d..cf40a006 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -55,13 +55,15 @@ instance (HasServer subApi) => newConfig = ("injected" :: String) :. config -data Descend (name :: Symbol) (subConfig :: [*]) subApi +data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) -instance HasServer subApi => HasServer (Descend name subConfig subApi) where - type ServerT (Descend name subConfig subApi) m = +instance (HasServer subApi) => + HasServer (NamedConfigWithBirdface name subConfig :> subApi) where + + type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = ServerT subApi m - type HasConfig (Descend name subConfig subApi) config = - (HasConfigEntry config (SubConfig name subConfig), HasConfig subApi subConfig) + type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) route Proxy config delayed = route subProxy subConfig delayed @@ -70,4 +72,4 @@ instance HasServer subApi => HasServer (Descend name subConfig subApi) where subProxy = Proxy subConfig :: Config subConfig - subConfig = descendIntoSubConfig (Proxy :: Proxy name) config + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config