server: use {c,C}onfig instead of {c,C}fg everywhere
This commit is contained in:
Sönke Hahn
parent
d8db0fa779
commit
6ca120f08f
6 changed files with 59 additions and 59 deletions
|
|
@ -285,7 +285,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
|||
|
||||
data WrappedApi where
|
||||
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a
|
||||
, HasCfg api '[], HasClient api
|
||||
, HasConfig api '[], HasClient api
|
||||
, Client api ~ ExceptT ServantError IO ()) =>
|
||||
Proxy api -> WrappedApi
|
||||
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@ data AuthProtected
|
|||
|
||||
instance HasServer rest => HasServer (AuthProtected :> rest) where
|
||||
type ServerT (AuthProtected :> rest) m = ServerT rest m
|
||||
type HasCfg (AuthProtected :> rest) config =
|
||||
(HasConfigEntry config DBConnection, HasCfg rest config)
|
||||
type HasConfig (AuthProtected :> rest) config =
|
||||
(HasConfigEntry config DBConnection, HasConfig rest config)
|
||||
|
||||
route Proxy config subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request
|
||||
|
|
|
|||
|
|
@ -101,18 +101,18 @@ import Servant.Server.Internal.Enter
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > cfg :: Config '[]
|
||||
-- > cfg = EmptyConfig
|
||||
-- > config :: Config '[]
|
||||
-- > config = EmptyConfig
|
||||
-- >
|
||||
-- > app :: Application
|
||||
-- > app = serve myApi cfg server
|
||||
-- > app = serve myApi config server
|
||||
-- >
|
||||
-- > main :: IO ()
|
||||
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
||||
--
|
||||
serve :: (HasCfg layout a, HasServer layout)
|
||||
serve :: (HasConfig layout a, HasServer layout)
|
||||
=> Proxy layout -> Config a -> Server layout -> Application
|
||||
serve p cfg server = toApplication (runRouter (route p cfg d))
|
||||
serve p config server = toApplication (runRouter (route p config d))
|
||||
where
|
||||
d = Delayed r r r (\ _ _ -> Route server)
|
||||
r = return (Route ())
|
||||
|
|
|
|||
|
|
@ -69,9 +69,9 @@ import Servant.Server.Internal.ServantErr
|
|||
|
||||
class HasServer layout where
|
||||
type ServerT layout (m :: * -> *) :: *
|
||||
type HasCfg layout (c :: [*]) :: Constraint
|
||||
type HasConfig layout (c :: [*]) :: Constraint
|
||||
|
||||
route :: HasCfg layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
|
||||
route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
|
||||
|
||||
type Server layout = ServerT layout (ExceptT ServantErr IO)
|
||||
|
||||
|
|
@ -91,10 +91,10 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)
|
|||
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
|
||||
|
||||
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
|
||||
type HasCfg (a :<|> b) c = (HasCfg a c, HasCfg b c)
|
||||
type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c)
|
||||
|
||||
route Proxy cfg server = choice (route pa cfg ((\ (a :<|> _) -> a) <$> server))
|
||||
(route pb cfg ((\ (_ :<|> b) -> b) <$> server))
|
||||
route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
|
||||
(route pb config ((\ (_ :<|> b) -> b) <$> server))
|
||||
where pa = Proxy :: Proxy a
|
||||
pb = Proxy :: Proxy b
|
||||
|
||||
|
|
@ -123,12 +123,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
|
|||
|
||||
type ServerT (Capture capture a :> sublayout) m =
|
||||
a -> ServerT sublayout m
|
||||
type HasCfg (Capture capture a :> sublayout) c = (HasCfg sublayout c)
|
||||
type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)
|
||||
|
||||
route Proxy cfg d =
|
||||
route Proxy config d =
|
||||
DynamicRouter $ \ first ->
|
||||
route (Proxy :: Proxy sublayout)
|
||||
cfg
|
||||
config
|
||||
(addCapture d $ case captured captureProxy first of
|
||||
Nothing -> return $ Fail err404
|
||||
Just v -> return $ Route v
|
||||
|
|
@ -200,7 +200,7 @@ instance OVERLAPPABLE_
|
|||
) => HasServer (Verb method status ctypes a) where
|
||||
|
||||
type ServerT (Verb method status ctypes a) m = m a
|
||||
type HasCfg (Verb method status ctypes a) c = ()
|
||||
type HasConfig (Verb method status ctypes a) c = ()
|
||||
|
||||
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
|
@ -212,7 +212,7 @@ instance OVERLAPPING_
|
|||
) => HasServer (Verb method status ctypes (Headers h a)) where
|
||||
|
||||
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
|
||||
type HasCfg (Verb method status ctypes (Headers h a)) c = ()
|
||||
type HasConfig (Verb method status ctypes (Headers h a)) c = ()
|
||||
|
||||
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
|
@ -243,11 +243,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
|
||||
type ServerT (Header sym a :> sublayout) m =
|
||||
Maybe a -> ServerT sublayout m
|
||||
type HasCfg (Header sym a :> sublayout) c = HasCfg sublayout c
|
||||
type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \ request ->
|
||||
route Proxy config subserver = WithRequest $ \ request ->
|
||||
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
|
||||
in route (Proxy :: Proxy sublayout) cfg (passToServer subserver mheader)
|
||||
in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader)
|
||||
where str = fromString $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
|
||||
|
|
@ -276,9 +276,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
|
||||
type ServerT (QueryParam sym a :> sublayout) m =
|
||||
Maybe a -> ServerT sublayout m
|
||||
type HasCfg (QueryParam sym a :> sublayout) c = HasCfg sublayout c
|
||||
type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \ request ->
|
||||
route Proxy config subserver = WithRequest $ \ request ->
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
param =
|
||||
case lookup paramname querytext of
|
||||
|
|
@ -286,7 +286,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
Just Nothing -> Nothing -- param present with no value -> Nothing
|
||||
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
|
||||
-- the right type
|
||||
in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param)
|
||||
in route (Proxy :: Proxy sublayout) config (passToServer subserver param)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
|
||||
|
|
@ -313,16 +313,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
|
||||
type ServerT (QueryParams sym a :> sublayout) m =
|
||||
[a] -> ServerT sublayout m
|
||||
type HasCfg (QueryParams sym a :> sublayout) c = HasCfg sublayout c
|
||||
type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \ request ->
|
||||
route Proxy config subserver = WithRequest $ \ request ->
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
-- if sym is "foo", we look for query string parameters
|
||||
-- named "foo" or "foo[]" and call parseQueryParam on the
|
||||
-- corresponding values
|
||||
parameters = filter looksLikeParam querytext
|
||||
values = mapMaybe (convert . snd) parameters
|
||||
in route (Proxy :: Proxy sublayout) cfg (passToServer subserver values)
|
||||
in route (Proxy :: Proxy sublayout) config (passToServer subserver values)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
|
||||
convert Nothing = Nothing
|
||||
|
|
@ -345,15 +345,15 @@ instance (KnownSymbol sym, HasServer sublayout)
|
|||
|
||||
type ServerT (QueryFlag sym :> sublayout) m =
|
||||
Bool -> ServerT sublayout m
|
||||
type HasCfg (QueryFlag sym :> sublayout) c = HasCfg sublayout c
|
||||
type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \ request ->
|
||||
route Proxy config subserver = WithRequest $ \ request ->
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
param = case lookup paramname querytext of
|
||||
Just Nothing -> True -- param is there, with no value
|
||||
Just (Just v) -> examine v -- param with a value
|
||||
Nothing -> False -- param not in the query string
|
||||
in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param)
|
||||
in route (Proxy :: Proxy sublayout) config (passToServer subserver param)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
| otherwise = False
|
||||
|
|
@ -369,7 +369,7 @@ instance (KnownSymbol sym, HasServer sublayout)
|
|||
instance HasServer Raw where
|
||||
|
||||
type ServerT Raw m = Application
|
||||
type HasCfg Raw c = ()
|
||||
type HasConfig Raw c = ()
|
||||
|
||||
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
|
||||
r <- runDelayed rawApplication
|
||||
|
|
@ -404,10 +404,10 @@ instance ( AllCTUnrender list a, HasServer sublayout
|
|||
|
||||
type ServerT (ReqBody list a :> sublayout) m =
|
||||
a -> ServerT sublayout m
|
||||
type HasCfg (ReqBody list a :> sublayout) c = HasCfg sublayout c
|
||||
type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy sublayout) cfg (addBodyCheck subserver (bodyCheck request))
|
||||
route Proxy config subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))
|
||||
where
|
||||
bodyCheck request = do
|
||||
-- See HTTP RFC 2616, section 7.2.1
|
||||
|
|
@ -428,42 +428,42 @@ instance ( AllCTUnrender list a, HasServer sublayout
|
|||
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
|
||||
|
||||
type ServerT (path :> sublayout) m = ServerT sublayout m
|
||||
type HasCfg (path :> sublayout) c = HasCfg sublayout c
|
||||
type HasConfig (path :> sublayout) c = HasConfig sublayout c
|
||||
|
||||
route Proxy cfg subserver = StaticRouter $
|
||||
route Proxy config subserver = StaticRouter $
|
||||
M.singleton (cs (symbolVal proxyPath))
|
||||
(route (Proxy :: Proxy sublayout) cfg subserver)
|
||||
(route (Proxy :: Proxy sublayout) config subserver)
|
||||
where proxyPath = Proxy :: Proxy path
|
||||
|
||||
instance HasServer api => HasServer (RemoteHost :> api) where
|
||||
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
|
||||
type HasCfg (RemoteHost :> api) c = HasCfg api c
|
||||
type HasConfig (RemoteHost :> api) c = HasConfig api c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) cfg (passToServer subserver $ remoteHost req)
|
||||
route Proxy config subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)
|
||||
|
||||
instance HasServer api => HasServer (IsSecure :> api) where
|
||||
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
|
||||
type HasCfg (IsSecure :> api) c = HasCfg api c
|
||||
type HasConfig (IsSecure :> api) c = HasConfig api c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) cfg (passToServer subserver $ secure req)
|
||||
route Proxy config subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) config (passToServer subserver $ secure req)
|
||||
|
||||
where secure req = if isSecure req then Secure else NotSecure
|
||||
|
||||
instance HasServer api => HasServer (Vault :> api) where
|
||||
type ServerT (Vault :> api) m = Vault -> ServerT api m
|
||||
type HasCfg (Vault :> api) c = HasCfg api c
|
||||
type HasConfig (Vault :> api) c = HasConfig api c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) cfg (passToServer subserver $ vault req)
|
||||
route Proxy config subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) config (passToServer subserver $ vault req)
|
||||
|
||||
instance HasServer api => HasServer (HttpVersion :> api) where
|
||||
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
|
||||
type HasCfg (HttpVersion :> api) c = HasCfg api c
|
||||
type HasConfig (HttpVersion :> api) c = HasConfig api c
|
||||
|
||||
route Proxy cfg subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req)
|
||||
route Proxy config subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
|
||||
|
||||
pathIsEmpty :: Request -> Bool
|
||||
pathIsEmpty = go . pathInfo
|
||||
|
|
@ -481,8 +481,8 @@ instance (HasServer subApi) =>
|
|||
|
||||
type ServerT (SubConfig name subConfig :> subApi) m =
|
||||
ServerT subApi m
|
||||
type HasCfg (SubConfig name subConfig :> subApi) config =
|
||||
(HasConfigEntry config (SubConfig name subConfig), HasCfg subApi subConfig)
|
||||
type HasConfig (SubConfig name subConfig :> subApi) config =
|
||||
(HasConfigEntry config (SubConfig name subConfig), HasConfig subApi subConfig)
|
||||
|
||||
route Proxy config delayed =
|
||||
route subProxy subConfig delayed
|
||||
|
|
|
|||
|
|
@ -33,8 +33,8 @@ instance Eq (Config '[]) where
|
|||
instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
|
||||
x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
|
||||
|
||||
class HasConfigEntry (cfg :: [*]) (val :: *) where
|
||||
getConfigEntry :: Config cfg -> val
|
||||
class HasConfigEntry (config :: [*]) (val :: *) where
|
||||
getConfigEntry :: Config config -> val
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@ instance (HasServer subApi) =>
|
|||
|
||||
type ServerT (ExtractFromConfig :> subApi) m =
|
||||
String -> ServerT subApi m
|
||||
type HasCfg (ExtractFromConfig :> subApi) (c :: [*]) =
|
||||
(HasConfigEntry c String, HasCfg subApi c)
|
||||
type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) =
|
||||
(HasConfigEntry c String, HasConfig subApi c)
|
||||
|
||||
route Proxy config delayed =
|
||||
route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
|
||||
|
|
@ -44,8 +44,8 @@ instance (HasServer subApi) =>
|
|||
|
||||
type ServerT (InjectIntoConfig :> subApi) m =
|
||||
ServerT subApi m
|
||||
type HasCfg (InjectIntoConfig :> subApi) c =
|
||||
(HasCfg subApi (String ': c))
|
||||
type HasConfig (InjectIntoConfig :> subApi) c =
|
||||
(HasConfig subApi (String ': c))
|
||||
|
||||
route Proxy config delayed =
|
||||
route subProxy newConfig delayed
|
||||
|
|
@ -60,8 +60,8 @@ data Descend (name :: Symbol) (subConfig :: [*]) subApi
|
|||
instance HasServer subApi => HasServer (Descend name subConfig subApi) where
|
||||
type ServerT (Descend name subConfig subApi) m =
|
||||
ServerT subApi m
|
||||
type HasCfg (Descend name subConfig subApi) config =
|
||||
(HasConfigEntry config (SubConfig name subConfig), HasCfg subApi subConfig)
|
||||
type HasConfig (Descend name subConfig subApi) config =
|
||||
(HasConfigEntry config (SubConfig name subConfig), HasConfig subApi subConfig)
|
||||
|
||||
route Proxy config delayed =
|
||||
route subProxy subConfig delayed
|
||||
|
|
|
|||
Loading…
Reference in a new issue