b0b02f1 · typeable/servant

git.iko.soy/typeable/servant

Implement `HasServer (NamedRoutes routes)`

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.

commitb0b02f194805372018deb4592da57ea25a35486a authorGaël Deest <gael.deest@tweag.io> dateThu 30 Sep 2021, 18:39 (5 years ago) parent65e3070

3 files changed+103−11

compare with master

unifiedsplit

servant-server/example/greet.hs+17−2 servant-server/servant-server.cabal+1 servant-server/src/Servant/Server/Generic.hs+85−9

servant-server/example/greet.hs+17−2

@@ -1,5 +1,6 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE RecordWildCards #-}

34{-# LANGUAGE OverloadedStrings #-}

45{-# LANGUAGE PolyKinds #-}

56{-# LANGUAGE TypeFamilies #-}

@@ -16,6 +17,8 @@ import Network.Wai

1617import Network.Wai.Handler.Warp

1718

1819import Servant

20+import Servant.Server.Generic ()

21+import Servant.API.Generic

1922

2023-- * Example

2124

@@ -38,6 +41,14 @@ type TestApi =

3841 -- DELETE /greet/:greetid

3942 :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent

4043

44+ :<|> NamedRoutes OtherRoutes

45+

46+data OtherRoutes mode = OtherRoutes

47+ { version :: mode :- Get '[JSON] Int

48+ , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text

49+ }

50+ deriving Generic

51+

4152testApi :: Proxy TestApi

4253testApi = Proxy

4354

@@ -48,9 +59,13 @@ testApi = Proxy

4859--

4960-- Each handler runs in the 'Handler' monad.

5061server :: Server TestApi

51−server = helloH :<|> postGreetH :<|> deleteGreetH

62+server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes

63+ where otherRoutes = OtherRoutes {..}

64+

65+ bye name = pure $ "Bye, " <> name <> " !"

66+ version = pure 42

5267

53− where helloH name Nothing = helloH name (Just False)

68+ helloH name Nothing = helloH name (Just False)

5469 helloH name (Just False) = return . Greet $ "Hello, " <> name

5570 helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name

5671

servant-server/servant-server.cabal+1

@@ -62,6 +62,7 @@ library

6262 build-depends:

6363 base >= 4.9 && < 4.16

6464 , bytestring >= 0.10.8.1 && < 0.12

65+ , constraints

6566 , containers >= 0.5.7.1 && < 0.7

6667 , mtl >= 2.2.2 && < 2.3

6768 , text >= 1.2.3.0 && < 1.3

servant-server/src/Servant/Server/Generic.hs+85−9

@@ -1,12 +1,20 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

9−{-# LANGUAGE UndecidableInstances #-}

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+{-# LANGUAGE AllowAmbiguousTypes #-}

3+{-# LANGUAGE ConstraintKinds #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE DefaultSignatures #-}

6+{-# LANGUAGE FlexibleContexts #-}

7+{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE InstanceSigs #-}

9+{-# LANGUAGE KindSignatures #-}

10+{-# LANGUAGE MultiParamTypeClasses #-}

11+{-# LANGUAGE QuantifiedConstraints #-}

12+{-# LANGUAGE RankNTypes #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE TypeApplications #-}

15+{-# LANGUAGE TypeFamilies #-}

16+{-# LANGUAGE TypeOperators #-}

17+{-# LANGUAGE UndecidableInstances #-}

1018-- | @since 0.14.1

1119module Servant.Server.Generic (

1220 AsServerT,

@@ -16,13 +24,20 @@ module Servant.Server.Generic (

1624 genericServeTWithContext,

1725 genericServer,

1826 genericServerT,

27+ -- * Internal machinery

28+ GServerConstraints,

29+ GServer,

30+ -- * Re-exports

31+ NamedRoutes

1932 ) where

2033

34+import Data.Constraint

2135import Data.Proxy

2236 (Proxy (..))

2337

2438import Servant.API.Generic

2539import Servant.Server

40+import Servant.Server.Internal

2641

2742-- | A type that specifies that an API record contains a server implementation.

2843data AsServerT (m :: * -> *)

@@ -97,3 +112,64 @@ genericServerT

97112 => routes (AsServerT m)

98113 -> ToServant routes (AsServerT m)

99114genericServerT = toServant

115+

116+-- | Set of constraints required to convert to / from vanilla server types.

117+type GServerConstraints api m =

118+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

119+ , GServantProduct (Rep (api (AsServerT m)))

120+ )

121+

122+-- | This class is a necessary evil: in the implementation of 'HasServer' for

123+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall

124+-- m. 'GServerConstraints' m@ to hold.

125+--

126+-- We cannot require do that directly as the definition of 'GServerConstraints'

127+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide

128+-- those type family applications behind a typeclass providing evidence for

129+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that

130+-- @forall m. 'GServer' api m@ instead.

131+--

132+-- Users shouldn't have to worry about this class, as the only possible instance

133+-- is provided in this module for all record APIs.

134+

135+class GServer (api :: * -> *) (m :: * -> *) where

136+ proof :: Dict (GServerConstraints api m)

137+

138+instance

139+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

140+ , GServantProduct (Rep (api (AsServerT m)))

141+ ) => GServer api m where

142+ proof = Dict

143+

144+instance

145+ ( HasServer (ToServantApi api) context

146+ , forall m. Generic (api (AsServerT m))

147+ , forall m. GServer api m

148+ ) => HasServer (NamedRoutes api) context where

149+

150+ type ServerT (NamedRoutes api) m = api (AsServerT m)

151+

152+ route

153+ :: Proxy (NamedRoutes api)

154+ -> Context context

155+ -> Delayed env (api (AsServerT Handler))

156+ -> Router env

157+ route _ ctx delayed =

158+ case proof @api @Handler of

159+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)

160+

161+ hoistServerWithContext

162+ :: forall m n. Proxy (NamedRoutes api)

163+ -> Proxy context

164+ -> (forall x. m x -> n x)

165+ -> api (AsServerT m)

166+ -> api (AsServerT n)

167+ hoistServerWithContext _ pctx nat server =

168+ case (proof @api @m, proof @api @n) of

169+ (Dict, Dict) ->

170+ fromServant servantSrvN

171+ where

172+ servantSrvM :: ServerT (ToServantApi api) m =

173+ toServant server

174+ servantSrvN :: ServerT (ToServantApi api) n =

175+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM