server/config: only have one combinator exposed (and renamings)
This commit is contained in:
parent
4f78e487a4
commit
7bf389090b
6 changed files with 46 additions and 43 deletions
|
@ -38,7 +38,8 @@ module Servant.Server
|
|||
|
||||
-- * Config
|
||||
, Config(..)
|
||||
, SubConfig(..)
|
||||
, NamedConfig(..)
|
||||
, WithNamedConfig(..)
|
||||
|
||||
-- * Default error type
|
||||
, ServantErr(..)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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\""
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue