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
, Config(..) , Config(..)
, SubConfig(..) , NamedConfig(..)
, WithNamedConfig(..)
-- * Default error type -- * Default error type
, ServantErr(..) , ServantErr(..)

View file

@ -33,7 +33,7 @@ import Data.String.Conversions (cs, (<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Typeable import Data.Typeable
import GHC.Exts (Constraint) import GHC.Exts (Constraint)
import GHC.TypeLits (KnownNat, KnownSymbol, natVal, import GHC.TypeLits (Symbol, KnownNat, KnownSymbol, natVal,
symbolVal) symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Socket (SockAddr) import Network.Socket (SockAddr)
@ -476,13 +476,13 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP
-- * configs -- * configs
instance (HasServer subApi) => data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi
HasServer (SubConfig name subConfig :> subApi) where
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 ServerT subApi m
type HasConfig (SubConfig name subConfig :> subApi) config = type HasConfig (WithNamedConfig name subConfig subApi) config =
(HasConfigEntry config (SubConfig name subConfig), HasConfig subApi subConfig) (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
route Proxy config delayed = route Proxy config delayed =
route subProxy subConfig delayed route subProxy subConfig delayed
@ -491,4 +491,4 @@ instance (HasServer subApi) =>
subProxy = Proxy subProxy = Proxy
subConfig :: Config subConfig 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 HasConfigEntry (val ': xs) val where
getConfigEntry (x :. _) = x getConfigEntry (x :. _) = x
-- * support for subconfigs -- * support for named subconfigs
data SubConfig (name :: Symbol) (subConfig :: [*]) data NamedConfig (name :: Symbol) (subConfig :: [*])
= SubConfig (Config subConfig) = NamedConfig (Config subConfig)
descendIntoSubConfig :: forall config name subConfig . descendIntoNamedConfig :: forall config name subConfig .
HasConfigEntry config (SubConfig name subConfig) => HasConfigEntry config (NamedConfig name subConfig) =>
Proxy (name :: Symbol) -> Config config -> Config subConfig Proxy (name :: Symbol) -> Config config -> Config subConfig
descendIntoSubConfig Proxy config = descendIntoNamedConfig Proxy config =
let SubConfig subConfig = getConfigEntry config :: SubConfig name subConfig let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig
in subConfig in subConfig

View file

@ -38,24 +38,24 @@ spec = do
let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig) let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)
show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)" show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"
describe "descendIntoSubConfig" $ do describe "descendIntoNamedConfig" $ do
let config :: Config [Char, SubConfig "sub" '[Char]] let config :: Config [Char, NamedConfig "sub" '[Char]]
config = config =
'a' :. 'a' :.
(SubConfig subConfig :: SubConfig "sub" '[Char]) (NamedConfig subConfig :: NamedConfig "sub" '[Char])
:. EmptyConfig :. EmptyConfig
subConfig = 'b' :. EmptyConfig subConfig = 'b' :. EmptyConfig
it "allows to extract subconfigs" $ do 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 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' `shouldBe` 'b'
it "does not typecheck if subConfig has the wrong type" $ do 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) shouldNotTypecheck (show x)
it "does not typecheck if subConfig with that name doesn't exist" $ do 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) shouldNotTypecheck (show x)

View file

@ -84,42 +84,42 @@ spec2 = do
it "allows to inject tagged config entries" $ do it "allows to inject tagged config entries" $ do
get "/tagged" `shouldRespondWith` "\"tagged: injected\"" get "/tagged" `shouldRespondWith` "\"tagged: injected\""
type SubConfigAPI = type WithBirdfaceAPI =
"foo" :> ExtractFromConfig :> Get '[JSON] String :<|> "foo" :> ExtractFromConfig :> Get '[JSON] String :<|>
SubConfig "sub" '[String] :> NamedConfigWithBirdface "sub" '[String] :>
"bar" :> ExtractFromConfig :> Get '[JSON] String "bar" :> ExtractFromConfig :> Get '[JSON] String
subConfigApp :: Application withBirdfaceApp :: Application
subConfigApp = serve (Proxy :: Proxy SubConfigAPI) config $ withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $
testServer :<|> testServer :<|>
testServer testServer
where where
config :: Config '[String, (SubConfig "sub" '[String])] config :: Config '[String, (NamedConfig "sub" '[String])]
config = config =
"firstEntry" :. "firstEntry" :.
(SubConfig ("secondEntry" :. EmptyConfig)) :. (NamedConfig ("secondEntry" :. EmptyConfig)) :.
EmptyConfig EmptyConfig
spec3 :: Spec spec3 :: Spec
spec3 = do spec3 = do
with (return subConfigApp) $ do with (return withBirdfaceApp) $ do
it "allows retrieving different ConfigEntries for the same combinator" $ do it "allows retrieving different ConfigEntries for the same combinator" $ do
get "/foo" `shouldRespondWith` "\"firstEntry\"" get "/foo" `shouldRespondWith` "\"firstEntry\""
get "/bar" `shouldRespondWith` "\"secondEntry\"" get "/bar" `shouldRespondWith` "\"secondEntry\""
type DescendAPI = type NamedConfigAPI =
Descend "sub" '[String] ( WithNamedConfig "sub" '[String] (
ExtractFromConfig :> Get '[JSON] String) ExtractFromConfig :> Get '[JSON] String)
descendApp :: Application namedConfigApp :: Application
descendApp = serve (Proxy :: Proxy DescendAPI) config return namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return
where where
config :: Config '[SubConfig "sub" '[String]] config :: Config '[NamedConfig "sub" '[String]]
config = SubConfig ("descend" :. EmptyConfig) :. EmptyConfig config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig
spec4 :: Spec spec4 :: Spec
spec4 = do spec4 = do
with (return descendApp) $ do with (return namedConfigApp) $ do
describe "Descend" $ do describe "WithNamedConfig" $ do
it "allows to descend into a subconfig for a given api" $ do it "allows to descend into a subconfig for a given api" $ do
get "/" `shouldRespondWith` "\"descend\"" get "/" `shouldRespondWith` "\"descend\""

View file

@ -55,13 +55,15 @@ instance (HasServer subApi) =>
newConfig = ("injected" :: String) :. config newConfig = ("injected" :: String) :. config
data Descend (name :: Symbol) (subConfig :: [*]) subApi data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])
instance HasServer subApi => HasServer (Descend name subConfig subApi) where instance (HasServer subApi) =>
type ServerT (Descend name subConfig subApi) m = HasServer (NamedConfigWithBirdface name subConfig :> subApi) where
type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =
ServerT subApi m ServerT subApi m
type HasConfig (Descend name subConfig subApi) config = type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config =
(HasConfigEntry config (SubConfig name subConfig), HasConfig subApi subConfig) (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
route Proxy config delayed = route Proxy config delayed =
route subProxy subConfig delayed route subProxy subConfig delayed
@ -70,4 +72,4 @@ instance HasServer subApi => HasServer (Descend name subConfig subApi) where
subProxy = Proxy subProxy = Proxy
subConfig :: Config subConfig subConfig :: Config subConfig
subConfig = descendIntoSubConfig (Proxy :: Proxy name) config subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config