servant/servant-server/src/Servant/Server/Generic.hs

176 lines
6.3 KiB
Haskell
Raw Normal View History

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
2018-07-04 21:59:43 +02:00
-- | @since 0.14.1
module Servant.Server.Generic (
AsServerT,
AsServer,
genericServe,
genericServeT,
genericServeTWithContext,
2018-07-04 21:59:43 +02:00
genericServer,
genericServerT,
-- * Internal machinery
GServerConstraints,
GServer,
-- * Re-exports
NamedRoutes
2018-07-04 21:59:43 +02:00
) where
import Data.Constraint
2018-07-04 21:59:43 +02:00
import Data.Proxy
(Proxy (..))
import Servant.API.Generic
import Servant.Server
import Servant.Server.Internal
2018-07-04 21:59:43 +02:00
-- | A type that specifies that an API record contains a server implementation.
data AsServerT (m :: * -> *)
instance GenericMode (AsServerT m) where
type AsServerT m :- api = ServerT api m
type AsServer = AsServerT Handler
-- | Transform a record of routes into a WAI 'Application'.
2018-07-04 21:59:43 +02:00
genericServe
:: forall routes.
( HasServer (ToServantApi routes) '[]
, GenericServant routes AsServer
, Server (ToServantApi routes) ~ ToServant routes AsServer
)
=> routes AsServer -> Application
genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer
-- | Transform a record of routes with custom monad into a WAI 'Application',
-- by providing a transformation to bring each handler back in the 'Handler'
-- monad.
genericServeT
:: forall (routes :: * -> *) (m :: * -> *).
( GenericServant routes (AsServerT m)
, GenericServant routes AsApi
, HasServer (ToServantApi routes) '[]
, ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)
)
=> (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'
-> routes (AsServerT m) -- ^ your record full of request handlers
-> Application
genericServeT f server = serve p $ hoistServer p f (genericServerT server)
where
p = genericApi (Proxy :: Proxy routes)
-- | Transform a record of routes with custom monad into a WAI 'Application',
-- while using the given 'Context' to serve the application (contexts are typically
-- used by auth-related combinators in servant, e.g to hold auth checks) and the given
-- transformation to map all the handlers back to the 'Handler' monad.
genericServeTWithContext
:: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]).
( GenericServant routes (AsServerT m)
, GenericServant routes AsApi
, HasServer (ToServantApi routes) ctx
, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters
, ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)
)
=> (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'
-> routes (AsServerT m) -- ^ your record full of request handlers
-> Context ctx -- ^ the 'Context' to serve the application with
-> Application
genericServeTWithContext f server ctx =
serveWithContext p ctx $
hoistServerWithContext p pctx f (genericServerT server)
where
p = genericApi (Proxy :: Proxy routes)
pctx = Proxy :: Proxy ctx
-- | Transform a record of endpoints into a 'Server'.
2018-07-04 21:59:43 +02:00
genericServer
:: GenericServant routes AsServer
=> routes AsServer
-> ToServant routes AsServer
genericServer = toServant
-- | Transform a record of endpoints into a @'ServerT' m@.
--
-- You can see an example usage of this function
-- <https://docs.servant.dev/en/stable/cookbook/generic/Generic.html#using-generics-together-with-a-custom-monad in the Servant Cookbook>.
2018-07-04 21:59:43 +02:00
genericServerT
:: GenericServant routes (AsServerT m)
=> routes (AsServerT m)
-> ToServant routes (AsServerT m)
genericServerT = toServant
-- | Set of constraints required to convert to / from vanilla server types.
type GServerConstraints api m =
( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
, GServantProduct (Rep (api (AsServerT m)))
)
-- | This class is a necessary evil: in the implementation of 'HasServer' for
-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
-- m. 'GServerConstraints' m@ to hold.
--
-- We cannot require do that directly as the definition of 'GServerConstraints'
-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
-- those type family applications behind a typeclass providing evidence for
-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
-- @forall m. 'GServer' api m@ instead.
--
-- Users shouldn't have to worry about this class, as the only possible instance
-- is provided in this module for all record APIs.
class GServer (api :: * -> *) (m :: * -> *) where
proof :: Dict (GServerConstraints api m)
instance
( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
, GServantProduct (Rep (api (AsServerT m)))
) => GServer api m where
proof = Dict
instance
( HasServer (ToServantApi api) context
, forall m. Generic (api (AsServerT m))
, forall m. GServer api m
) => HasServer (NamedRoutes api) context where
type ServerT (NamedRoutes api) m = api (AsServerT m)
route
:: Proxy (NamedRoutes api)
-> Context context
-> Delayed env (api (AsServerT Handler))
-> Router env
route _ ctx delayed =
case proof @api @Handler of
Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
hoistServerWithContext
:: forall m n. Proxy (NamedRoutes api)
-> Proxy context
-> (forall x. m x -> n x)
-> api (AsServerT m)
-> api (AsServerT n)
hoistServerWithContext _ pctx nat server =
case (proof @api @m, proof @api @n) of
(Dict, Dict) ->
fromServant servantSrvN
where
servantSrvM :: ServerT (ToServantApi api) m =
toServant server
servantSrvN :: ServerT (ToServantApi api) n =
hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM