server/config: only have one combinator exposed (and renamings)

This commit is contained in:
Sönke Hahn 2016-01-14 23:32:25 +01:00
parent 4f78e487a4
commit 7bf389090b
6 changed files with 46 additions and 43 deletions

View file

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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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\""

View file

@ -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