From b0b02f194805372018deb4592da57ea25a35486a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 30 Sep 2021 18:39:41 +0200 Subject: [PATCH] Implement `HasServer (NamedRoutes routes)` MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We define `ServerT (NamedRoutes api) m` as `api (AsServerT m)`, so that the server of an record-defined API is a record of handlers. The implementation piggy backs on the instance for “vanilla” servant types with `(:<|>)`, using the `GServantProduct` for converting backd and forth between the record / vanilla servers. The main difficulty is that GHC needs to know that this operation is legit, which can be expressed as the fact that: ``` GToServant (Rep (ServerT (NamedRoutes api))) m ~ ServerT (GToServant (Rep (api AsApi))) m ``` plus a few additional constraints. This is easy enough for `route`, as we know that `m ~ Handler`. But in the case of `hoistServerWithContext`, the two involved monads are unknown ; in other words, this constraint needs to hold `forall m.` Switching `-XQuantifiedConstraints` on is not sufficient, as our constraints involve type families (`Rep` and `ServerT`). Our trick is to use an intermediary typeclass, `GServer`, as a provider of evidence (in the form of a `Dict`) that our constraints are indeed satisfied for a particular monad. The only instance of `GServer` is defined along with it, so it is practically invisible to users. --- servant-server/example/greet.hs | 19 +++- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server/Generic.hs | 94 ++++++++++++++++++-- 3 files changed, 103 insertions(+), 11 deletions(-) diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index e354351f..5d95ddca 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -16,6 +17,8 @@ import Network.Wai import Network.Wai.Handler.Warp import Servant +import Servant.Server.Generic () +import Servant.API.Generic -- * Example @@ -38,6 +41,14 @@ type TestApi = -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + :<|> NamedRoutes OtherRoutes + +data OtherRoutes mode = OtherRoutes + { version :: mode :- Get '[JSON] Int + , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text + } + deriving Generic + testApi :: Proxy TestApi testApi = Proxy @@ -48,9 +59,13 @@ testApi = Proxy -- -- Each handler runs in the 'Handler' monad. server :: Server TestApi -server = helloH :<|> postGreetH :<|> deleteGreetH +server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes + where otherRoutes = OtherRoutes {..} - where helloH name Nothing = helloH name (Just False) + bye name = pure $ "Bye, " <> name <> " !" + version = pure 42 + + helloH name Nothing = helloH name (Just False) helloH name (Just False) = return . Greet $ "Hello, " <> name helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 86e00d31..709772f0 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -62,6 +62,7 @@ library build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 + , constraints , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3 , text >= 1.2.3.0 && < 1.3 diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index c3db01c3..c4a6f934 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -1,12 +1,20 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# 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 #-} -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, @@ -16,13 +24,20 @@ module Servant.Server.Generic ( genericServeTWithContext, genericServer, genericServerT, + -- * Internal machinery + GServerConstraints, + GServer, + -- * Re-exports + NamedRoutes ) where +import Data.Constraint import Data.Proxy (Proxy (..)) import Servant.API.Generic import Servant.Server +import Servant.Server.Internal -- | A type that specifies that an API record contains a server implementation. data AsServerT (m :: * -> *) @@ -97,3 +112,64 @@ genericServerT => 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