eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #1388 from gdeest/generic-apis

Browse source 
Improve API for composing generic routes
This commit is contained in:
Gaël Deest 2021-11-18 10:21:59 +01:00 committed by GitHub
commit 1bb0282abc
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
15 changed files with 359 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client-core/servant-client-core.cabal
View file

@ -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

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

@ -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'

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

@ -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

19
servant-client-core/src/Servant/Client/Generic.hs
View file

@ -1,9 +1,10 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.Client.Generic (
AsClientT,
genericClient,
@ -15,11 +16,7 @@ import Data.Proxy
import Servant.API.Generic
import Servant.Client.Core
-- | 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
import Servant.Client.Core.HasClient (AsClientT)
-- | Generate a record of client functions.
genericClient

1
servant-client/servant-client.cabal
View file

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

25
servant-client/test/Servant/ClientTestUtils.hs
View file

@ -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 =

37
servant-client/test/Servant/GenericSpec.hs Normal file
View file

@ -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"]

19
servant-server/example/greet.hs
View file

@ -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

1
servant-server/servant-server.cabal
View file

@ -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

29
servant-server/src/Servant/Server/Generic.hs
View file

@ -1,12 +1,10 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | @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
-- | 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
import Servant.API.Generic
import Servant.Server.Internal
-- | Transform a record of routes into a WAI 'Application'.
genericServe
@ -97,3 +89,4 @@ genericServerT
=> routes (AsServerT m)
-> ToServant routes (AsServerT m)
genericServerT = toServant

93
servant-server/src/Servant/Server/Internal.hs
View file

@ -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

2
servant/servant.cabal
View file

@ -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

5
servant/src/Servant/API.hs
View file

@ -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,

10
servant/src/Servant/API/NamedRoutes.hs Normal file
View file

@ -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 :: * -> *)

36
servant/src/Servant/Links.hs
View file

@ -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