Merge pull request #1388 from gdeest/generic-apis

Improve API for composing generic routes

servant-client-core/servant-client-core.cabal

@@ -52,6 +52,7 @@ library
   build-depends:
       base                  >= 4.9      && < 4.16
     , bytestring            >= 0.10.8.1 && < 0.12
+    , constraints           >= 0.2      && < 0.14
     , containers            >= 0.5.7.1  && < 0.7
     , deepseq               >= 1.4.2.0  && < 1.5
     , text                  >= 1.2.3.0  && < 1.3

servant-client-core/src/Servant/Client/Core/HasClient.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@@ -7,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
@@ -14,14 +14,13 @@
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
-#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
-#define HAS_TYPE_ERROR
-#endif
-
 module Servant.Client.Core.HasClient (
     clientIn,
     HasClient (..),
     EmptyClient (..),
+    AsClientT,
+    (//),
+    (/:),
     foldMapUnion,
     matchUnion,
     ) where
@@ -39,6 +38,7 @@ import           Data.ByteString.Builder
 import qualified Data.ByteString.Lazy                     as BL
 import           Data.Either
                  (partitionEithers)
+import           Data.Constraint (Dict(..))
 import           Data.Foldable
                  (toList)
 import           Data.List
@@ -47,7 +47,8 @@ import           Data.Sequence
                  (fromList)
 import qualified Data.Text                       as T
 import           Network.HTTP.Media
-                 (MediaType, matches, parseAccept, (//))
+                 (MediaType, matches, parseAccept)
+import qualified Network.HTTP.Media as Media
 import qualified Data.Sequence as Seq
 import           Data.SOP.BasicFunctors
                  (I (I), (:.:) (Comp))
@@ -79,7 +80,10 @@ import           Servant.API
                  ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
                  StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
                  Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
-                 getResponse, toEncodedUrlPiece, toUrlPiece)
+                 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
+import           Servant.API.Generic
+                 (GenericMode(..), ToServant, ToServantApi
+                 , GenericServant, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
 import           Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
@@ -792,11 +796,7 @@ instance ( HasClient m api
 -- > getBooks = client myApi
 -- > -- then you can just use "getBooksBy" to query that endpoint.
 -- > -- 'getBooks' for all books.
-#ifdef HAS_TYPE_ERROR
 instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
-#else
-instance ( HasClient m api
-#endif
          ) => HasClient m (Fragment a :> api) where
 
   type Client m (Fragment a :> api) = Client m api
@@ -816,6 +816,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
   hoistClientMonad pm _ f cl = \bauth ->
     hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
 
+-- | A type that specifies that an API record contains a client implementation.
+data AsClientT (m :: * -> *)
+instance GenericMode (AsClientT m) where
+    type AsClientT m :- api = Client m api
+
+
+type GClientConstraints api m =
+  ( GenericServant api (AsClientT m)
+  , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
+  )
+
+class GClient (api :: * -> *) m where
+  proof :: Dict (GClientConstraints api m)
+
+instance GClientConstraints api m => GClient api m where
+  proof = Dict
+
+instance
+  ( forall n. GClient api n
+  , HasClient m (ToServantApi api)
+  , RunClient m
+  )
+  => HasClient m (NamedRoutes api) where
+  type Client m (NamedRoutes api) = api (AsClientT m)
+
+  clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
+  clientWithRoute pm _ request =
+    case proof @api @m of
+      Dict -> fromServant $ clientWithRoute  pm (Proxy @(ToServantApi api)) request
+
+  hoistClientMonad
+    :: forall ma mb.
+       Proxy m
+    -> Proxy (NamedRoutes api)
+    -> (forall x. ma x -> mb x)
+    -> Client ma (NamedRoutes api)
+    -> Client mb (NamedRoutes api)
+  hoistClientMonad _ _ nat clientA =
+    case (proof @api @ma, proof @api @mb) of
+      (Dict, Dict) ->
+        fromServant @api @(AsClientT mb) $
+        hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
+        toServant @api @(AsClientT ma) clientA
+
+infixl 1 //
+infixl 2 /:
+
+-- | Helper to make code using records of clients more readable.
+--
+-- Can be mixed with (/:) for supplying arguments.
+--
+-- Example:
+--
+-- @@
+-- type Api = NamedRoutes RootApi
+--
+-- data RootApi mode = RootApi
+--   { subApi :: mode :- NamedRoutes SubApi
+--   , …
+--   } deriving Generic
+--
+-- data SubApi mode = SubApi
+--   { endpoint :: mode :- Get '[JSON] Person
+--   , …
+--   } deriving Generic
+--
+-- api :: Proxy API
+-- api = Proxy
+--
+-- rootClient :: RootApi (AsClientT ClientM)
+-- rootClient = client api
+--
+-- endpointClient :: ClientM Person
+-- endpointClient = client // subApi // endpoint
+-- @@
+(//) :: a -> (a -> b) -> b
+x // f = f x
+
+-- | Convenience function for supplying arguments to client functions when
+-- working with records of clients.
+--
+-- Intended to be used in conjunction with '(//)'.
+--
+-- Example:
+--
+-- @@
+-- type Api = NamedRoutes RootApi
+--
+-- data RootApi mode = RootApi
+--   { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
+--   , hello :: mode :- Capture "name" String :> Get '[JSON] String
+--   , …
+--   } deriving Generic
+--
+-- data SubApi mode = SubApi
+--   { endpoint :: mode :- Get '[JSON] Person
+--   , …
+--   } deriving Generic
+--
+-- api :: Proxy API
+-- api = Proxy
+--
+-- rootClient :: RootApi (AsClientT ClientM)
+-- rootClient = client api
+--
+-- hello :: String -> ClientM String
+-- hello name = rootClient // hello /: name
+--
+-- endpointClient :: ClientM Person
+-- endpointClient = client // subApi /: "foobar123" // endpoint
+-- @@
+(/:) :: (a -> b -> c) -> b -> a -> c
+(/:) = flip
 
 
 {- Note [Non-Empty Content Types]
@@ -841,7 +954,7 @@ for empty and one for non-empty lists).
 checkContentTypeHeader :: RunClient m => Response -> m MediaType
 checkContentTypeHeader response =
   case lookup "Content-Type" $ toList $ responseHeaders response of
-    Nothing -> return $ "application"//"octet-stream"
+    Nothing -> return $ "application" Media.// "octet-stream"
     Just t -> case parseAccept t of
       Nothing -> throwClientError $ InvalidContentTypeHeader response
       Just t' -> return t'

servant-client-core/src/Servant/Client/Core/Reexport.hs

@@ -7,6 +7,9 @@ module Servant.Client.Core.Reexport
     HasClient(..)
   , foldMapUnion
   , matchUnion
+  , AsClientT
+  , (//)
+  , (/:)
 
     -- * Response (for @Raw@)
   , Response
@@ -23,6 +26,7 @@ module Servant.Client.Core.Reexport
   , showBaseUrl
   , parseBaseUrl
   , InvalidBaseUrlException
+
   ) where
 
 

servant-client-core/src/Servant/Client/Generic.hs

@@ -1,9 +1,10 @@
-{-# LANGUAGE ConstraintKinds     #-}
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
-{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE KindSignatures        #-}
-{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeFamilies          #-}
+
 module  Servant.Client.Generic (
     AsClientT,
     genericClient,
@@ -15,11 +16,7 @@ import           Data.Proxy
 
 import           Servant.API.Generic
 import           Servant.Client.Core
-
+import           Servant.Client.Core.HasClient (AsClientT)
--- | A type that specifies that an API record contains a client implementation.
-data AsClientT (m :: * -> *)
-instance GenericMode (AsClientT m) where
-    type AsClientT m :- api = Client m api
 
 -- | Generate a record of client functions.
 genericClient

servant-client/servant-client.cabal

@@ -93,6 +93,7 @@ test-suite spec
       Servant.ConnectionErrorSpec
       Servant.FailSpec
       Servant.GenAuthSpec
+      Servant.GenericSpec
       Servant.HoistClientSpec
       Servant.StreamSpec
       Servant.SuccessSpec

servant-client/test/Servant/ClientTestUtils.hs

@@ -64,7 +64,8 @@ import           Servant.API
                  JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
                  NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
                  QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
-                 WithStatus (WithStatus), addHeader)
+                 WithStatus (WithStatus), NamedRoutes, addHeader)
+import           Servant.API.Generic ((:-))
 import           Servant.Client
 import qualified Servant.Client.Core.Auth         as Auth
 import           Servant.Server
@@ -107,6 +108,16 @@ carol = Person "Carol" 17
 
 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 
+data RecordRoutes mode = RecordRoutes
+  { version :: mode :- "version" :> Get '[JSON] Int
+  , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
+  , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes
+  } deriving Generic
+
+data OtherRoutes mode = OtherRoutes
+  { something :: mode :- "something" :> Get '[JSON] [String]
+  } deriving Generic
+
 type Api =
   Get '[JSON] Person
   :<|> "get" :> Get '[JSON] Person
@@ -141,6 +152,7 @@ type Api =
             UVerb 'GET '[PlainText] '[WithStatus 200 Person,
                                       WithStatus 301 Text]
   :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
+  :<|> NamedRoutes RecordRoutes
 
 
 api :: Proxy Api
@@ -170,6 +182,7 @@ uverbGetSuccessOrRedirect :: Bool
                           -> ClientM (Union '[WithStatus 200 Person,
                                               WithStatus 301 Text])
 uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
+recordRoutes :: RecordRoutes (AsClientT ClientM)
 
 getRoot
   :<|> getGet
@@ -192,7 +205,8 @@ getRoot
   :<|> getRedirectWithCookie
   :<|> EmptyClient
   :<|> uverbGetSuccessOrRedirect
-  :<|> uverbGetCreated = client api
+  :<|> uverbGetCreated
+  :<|> recordRoutes = client api
 
 server :: Application
 server = serve api (
@@ -229,6 +243,13 @@ server = serve api (
                               then respond (WithStatus @301 ("redirecting" :: Text))
                               else respond (WithStatus @200 alice ))
   :<|> respond (WithStatus @201 carol)
+  :<|> RecordRoutes
+         { version = pure 42
+         , echo = pure
+         , otherRoutes = \_ -> OtherRoutes
+             { something = pure ["foo", "bar", "pweet"]
+             }
+         }
   )
 
 type FailApi =

servant-client/test/Servant/GenericSpec.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.GenericSpec (spec) where
+
+import           Test.Hspec
+
+import           Servant.Client ((//), (/:))
+import           Servant.ClientTestUtils
+
+spec :: Spec
+spec = describe "Servant.GenericSpec" $ do
+    genericSpec
+
+genericSpec :: Spec
+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
+  context "Record clients work as expected" $ do
+
+    it "Client functions return expected values" $ \(_,baseUrl) -> do
+      runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42
+      runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"
+    it "Clients can be nested" $ \(_,baseUrl) -> do
+      runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]

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
 

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         >= 0.2      && < 0.14
     , containers          >= 0.5.7.1  && < 0.7
     , mtl                 >= 2.2.2    && < 2.3
     , text                >= 1.2.3.0  && < 1.3

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

@@ -1,12 +1,10 @@
-{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE RankNTypes             #-}
-{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE TypeFamilies           #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeOperators          #-}
-{-# LANGUAGE TypeFamilies         #-}
+
-{-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE UndecidableInstances #-}
 -- | @since 0.14.1
 module Servant.Server.Generic (
     AsServerT,
@@ -15,21 +13,15 @@ module Servant.Server.Generic (
     genericServeT,
     genericServeTWithContext,
     genericServer,
-    genericServerT,
+    genericServerT
   ) where
 
 import           Data.Proxy
                  (Proxy (..))
 
-import           Servant.API.Generic
 import           Servant.Server
-
+import           Servant.API.Generic
--- | A type that specifies that an API record contains a server implementation.
+import           Servant.Server.Internal
-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'.
 genericServe
@@ -97,3 +89,4 @@ genericServerT
     => routes (AsServerT m)
     -> ToServant routes (AsServerT m)
 genericServerT = toServant
+

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

@@ -1,23 +1,22 @@
-{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
-#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
-#define HAS_TYPE_ERROR
-#endif
-
 module Servant.Server.Internal
   ( module Servant.Server.Internal
   , module Servant.Server.Internal.BasicAuth
@@ -42,6 +41,7 @@ import qualified Data.ByteString                            as B
 import qualified Data.ByteString.Builder                    as BB
 import qualified Data.ByteString.Char8                      as BC8
 import qualified Data.ByteString.Lazy                       as BL
+import           Data.Constraint (Dict(..))
 import           Data.Either
                  (partitionEithers)
 import           Data.Maybe
@@ -54,6 +54,7 @@ import           Data.Tagged
                  (Tagged (..), retag, untag)
 import qualified Data.Text                                  as T
 import           Data.Typeable
+import           GHC.Generics
 import           GHC.TypeLits
                  (KnownNat, KnownSymbol, natVal, symbolVal)
 import qualified Network.HTTP.Media                         as NHM
@@ -75,7 +76,8 @@ import           Servant.API
                  QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
                  RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
                  Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
-                 WithNamedContext)
+                 WithNamedContext, NamedRoutes)
+import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
                  AllMime, MimeRender (..), MimeUnrender (..), NoContent,
@@ -101,12 +103,10 @@ import           Servant.Server.Internal.RouteResult
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServerError
 
-#ifdef HAS_TYPE_ERROR
 import           GHC.TypeLits
                  (ErrorMessage (..), TypeError)
 import           Servant.API.TypeLevel
                  (AtLeastOneFragment, FragmentUnique)
-#endif
 
 class HasServer api context where
   type ServerT api (m :: * -> *) :: *
@@ -784,7 +784,7 @@ instance ( KnownSymbol realm
 -- * helpers
 
 ct_wildcard :: B.ByteString
-ct_wildcard = "*" <> "/" <> "*" -- Because CPP
+ct_wildcard = "*" <> "/" <> "*"
 
 getAcceptHeader :: Request -> AcceptHeader
 getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
@@ -815,7 +815,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
 -- TypeError helpers
 -------------------------------------------------------------------------------
 
-#ifdef HAS_TYPE_ERROR
 -- | This instance catches mistakes when there are non-saturated
 -- type applications on LHS of ':>'.
 --
@@ -878,7 +877,6 @@ type HasServerArrowTypeError a b =
     ':$$: 'ShowType a
     ':$$: 'Text "and"
     ':$$: 'ShowType b
-#endif
 
 -- | Ignore @'Fragment'@ in server handlers.
 -- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
@@ -891,11 +889,7 @@ type HasServerArrowTypeError a b =
 -- > server = getBooks
 -- >   where getBooks :: Handler [Book]
 -- >         getBooks = ...return all books...
-#ifdef HAS_TYPE_ERROR
 instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
-#else
-instance (HasServer api context)
-#endif
     => HasServer (Fragment a1 :> api) context where
   type ServerT (Fragment a1 :> api) m = ServerT api m
 
@@ -905,3 +899,72 @@ instance (HasServer api context)
 
 -- $setup
 -- >>> import Servant
+
+-- | 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
+
+
+-- | 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

servant/servant.cabal

@@ -46,6 +46,7 @@ library
     Servant.API.HttpVersion
     Servant.API.IsSecure
     Servant.API.Modifiers
+    Servant.API.NamedRoutes
     Servant.API.QueryParam
     Servant.API.Raw
     Servant.API.RemoteHost
@@ -80,6 +81,7 @@ library
   build-depends:
       base                   >= 4.9      && < 4.16
     , bytestring             >= 0.10.8.1 && < 0.12
+    , constraints            >= 0.2
     , mtl                    >= 2.2.2    && < 2.3
     , sop-core               >= 0.4.0.0  && < 0.6
     , transformers           >= 0.5.2.0  && < 0.6

servant/src/Servant/API.hs

@@ -36,6 +36,9 @@ module Servant.API (
   module Servant.API.Verbs,
   module Servant.API.UVerb,
 
+  -- * Sub-APIs defined as records of routes
+  module Servant.API.NamedRoutes,
+
   -- * Streaming endpoints, distinguished by HTTP method
   module Servant.API.Stream,
 
@@ -130,6 +133,8 @@ import           Servant.API.UVerb
                  Unique, WithStatus (..), inject, statusOf)
 import           Servant.API.Vault
                  (Vault)
+import           Servant.API.NamedRoutes
+                 (NamedRoutes)
 import           Servant.API.Verbs
                  (Delete, DeleteAccepted, DeleteNoContent,
                  DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

servant/src/Servant/API/NamedRoutes.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE KindSignatures #-}
+{-# OPTIONS_HADDOCK not-home    #-}
+
+module Servant.API.NamedRoutes (
+    -- * NamedRoutes combinator
+    NamedRoutes
+  ) where
+
+-- | Combinator for embedding a record of named routes into a Servant API type.
+data NamedRoutes (api :: * -> *)

servant/src/Servant/Links.hs

@@ -1,13 +1,18 @@
+{-# LANGUAGE AllowAmbiguousTypes    #-}
 {-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE InstanceSigs           #-}
 {-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE QuantifiedConstraints    #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
+
 {-# OPTIONS_HADDOCK not-home        #-}
 
 -- | Type safe generation of internal links.
@@ -125,6 +130,7 @@ module Servant.Links (
 ) where
 
 import           Data.List
+import           Data.Constraint
 import           Data.Proxy
                  (Proxy (..))
 import           Data.Singletons.Bool
@@ -163,6 +169,8 @@ import           Servant.API.IsSecure
                  (IsSecure)
 import           Servant.API.Modifiers
                  (FoldRequired)
+import           Servant.API.NamedRoutes
+                 (NamedRoutes)
 import           Servant.API.QueryParam
                  (QueryFlag, QueryParam', QueryParams)
 import           Servant.API.Raw
@@ -579,6 +587,34 @@ instance HasLink (Stream m status fr ct a) where
 instance HasLink (UVerb m ct a) where
     type MkLink (UVerb m ct a) r = r
     toLink toA _ = toA
+-- Instance for NamedRoutes combinator
+
+type GLinkConstraints routes a =
+  ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)
+  , GenericServant routes (AsLink a)
+  )
+
+class GLink (routes :: * -> *) (a :: *) where
+  proof :: Dict (GLinkConstraints routes a)
+
+instance GLinkConstraints routes a => GLink routes a where
+  proof = Dict
+
+instance
+  ( HasLink (ToServantApi routes)
+  , forall a. GLink routes a
+  ) => HasLink (NamedRoutes routes) where
+
+  type MkLink (NamedRoutes routes) a = routes (AsLink a)
+
+  toLink
+    :: forall a. (Link -> a)
+    -> Proxy (NamedRoutes routes)
+    -> Link
+    -> routes (AsLink a)
+
+  toLink toA _ l = case proof @routes @a of
+    Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l
 
 -- AuthProtext instances
 instance HasLink sub => HasLink (AuthProtect tag :> sub) where