1bb0282 · typeable/servant

servant-client-core/servant-client-core.cabal+1

@@ -52,6 +52,7 @@ library

5252 build-depends:

5353 base >= 4.9 && < 4.16

5454 , bytestring >= 0.10.8.1 && < 0.12

55+ , constraints >= 0.2 && < 0.14

5556 , containers >= 0.5.7.1 && < 0.7

5657 , deepseq >= 1.4.2.0 && < 1.5

5758 , text >= 1.2.3.0 && < 1.3

servant-client-core/src/Servant/Client/Core/HasClient.hs+125−12

@@ -1,5 +1,4 @@

11{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

@@ -7,6 +6,7 @@

76{-# LANGUAGE MultiParamTypeClasses #-}

87{-# LANGUAGE OverloadedStrings #-}

98{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE QuantifiedConstraints #-}

1010{-# LANGUAGE RankNTypes #-}

1111{-# LANGUAGE ScopedTypeVariables #-}

1212{-# LANGUAGE TypeApplications #-}

@@ -14,14 +14,13 @@

1414{-# LANGUAGE TypeOperators #-}

1515{-# LANGUAGE UndecidableInstances #-}

1616

17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

18−#define HAS_TYPE_ERROR

19−#endif

20−

2117module Servant.Client.Core.HasClient (

2218 clientIn,

2319 HasClient (..),

2420 EmptyClient (..),

21+ AsClientT,

22+ (//),

23+ (/:),

2524 foldMapUnion,

2625 matchUnion,

2726 ) where

@@ -39,6 +38,7 @@ import Data.ByteString.Builder

3938import qualified Data.ByteString.Lazy as BL

4039import Data.Either

4140 (partitionEithers)

41+import Data.Constraint (Dict(..))

4242import Data.Foldable

4343 (toList)

4444import Data.List

@@ -47,7 +47,8 @@ import Data.Sequence

4747 (fromList)

4848import qualified Data.Text as T

4949import Network.HTTP.Media

50− (MediaType, matches, parseAccept, (//))

50+ (MediaType, matches, parseAccept)

51+import qualified Network.HTTP.Media as Media

5152import qualified Data.Sequence as Seq

5253import Data.SOP.BasicFunctors

5354 (I (I), (:.:) (Comp))

@@ -79,7 +80,10 @@ import Servant.API

7980 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

8081 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

8182 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,

82− getResponse, toEncodedUrlPiece, toUrlPiece)

83+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

84+import Servant.API.Generic

85+ (GenericMode(..), ToServant, ToServantApi

86+ , GenericServant, toServant, fromServant)

8387import Servant.API.ContentTypes

8488 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

8589import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

@@ -792,11 +796,7 @@ instance ( HasClient m api

792796-- > getBooks = client myApi

793797-- > -- then you can just use "getBooksBy" to query that endpoint.

794798-- > -- 'getBooks' for all books.

795−#ifdef HAS_TYPE_ERROR

796799instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api

797−#else

798−instance ( HasClient m api

799−#endif

800800 ) => HasClient m (Fragment a :> api) where

801801

802802 type Client m (Fragment a :> api) = Client m api

@@ -816,6 +816,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

816816 hoistClientMonad pm _ f cl = \bauth ->

817817 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)

818818

819+-- | A type that specifies that an API record contains a client implementation.

820+data AsClientT (m :: * -> *)

821+instance GenericMode (AsClientT m) where

822+ type AsClientT m :- api = Client m api

823+

824+

825+type GClientConstraints api m =

826+ ( GenericServant api (AsClientT m)

827+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)

828+ )

829+

830+class GClient (api :: * -> *) m where

831+ proof :: Dict (GClientConstraints api m)

832+

833+instance GClientConstraints api m => GClient api m where

834+ proof = Dict

835+

836+instance

837+ ( forall n. GClient api n

838+ , HasClient m (ToServantApi api)

839+ , RunClient m

840+ )

841+ => HasClient m (NamedRoutes api) where

842+ type Client m (NamedRoutes api) = api (AsClientT m)

843+

844+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)

845+ clientWithRoute pm _ request =

846+ case proof @api @m of

847+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request

848+

849+ hoistClientMonad

850+ :: forall ma mb.

851+ Proxy m

852+ -> Proxy (NamedRoutes api)

853+ -> (forall x. ma x -> mb x)

854+ -> Client ma (NamedRoutes api)

855+ -> Client mb (NamedRoutes api)

856+ hoistClientMonad _ _ nat clientA =

857+ case (proof @api @ma, proof @api @mb) of

858+ (Dict, Dict) ->

859+ fromServant @api @(AsClientT mb) $

860+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $

861+ toServant @api @(AsClientT ma) clientA

862+

863+infixl 1 //

864+infixl 2 /:

865+

866+-- | Helper to make code using records of clients more readable.

867+--

868+-- Can be mixed with (/:) for supplying arguments.

869+--

870+-- Example:

871+--

872+-- @@

873+-- type Api = NamedRoutes RootApi

874+--

875+-- data RootApi mode = RootApi

876+-- { subApi :: mode :- NamedRoutes SubApi

877+-- , …

878+-- } deriving Generic

879+--

880+-- data SubApi mode = SubApi

881+-- { endpoint :: mode :- Get '[JSON] Person

882+-- , …

883+-- } deriving Generic

884+--

885+-- api :: Proxy API

886+-- api = Proxy

887+--

888+-- rootClient :: RootApi (AsClientT ClientM)

889+-- rootClient = client api

890+--

891+-- endpointClient :: ClientM Person

892+-- endpointClient = client // subApi // endpoint

893+-- @@

894+(//) :: a -> (a -> b) -> b

895+x // f = f x

896+

897+-- | Convenience function for supplying arguments to client functions when

898+-- working with records of clients.

899+--

900+-- Intended to be used in conjunction with '(//)'.

901+--

902+-- Example:

903+--

904+-- @@

905+-- type Api = NamedRoutes RootApi

906+--

907+-- data RootApi mode = RootApi

908+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi

909+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String

910+-- , …

911+-- } deriving Generic

912+--

913+-- data SubApi mode = SubApi

914+-- { endpoint :: mode :- Get '[JSON] Person

915+-- , …

916+-- } deriving Generic

917+--

918+-- api :: Proxy API

919+-- api = Proxy

920+--

921+-- rootClient :: RootApi (AsClientT ClientM)

922+-- rootClient = client api

923+--

924+-- hello :: String -> ClientM String

925+-- hello name = rootClient // hello /: name

926+--

927+-- endpointClient :: ClientM Person

928+-- endpointClient = client // subApi /: "foobar123" // endpoint

929+-- @@

930+(/:) :: (a -> b -> c) -> b -> a -> c

931+(/:) = flip

819932

820933

821934{- Note [Non-Empty Content Types]

@@ -841,7 +954,7 @@ for empty and one for non-empty lists).

841954checkContentTypeHeader :: RunClient m => Response -> m MediaType

842955checkContentTypeHeader response =

843956 case lookup "Content-Type" $ toList $ responseHeaders response of

844− Nothing -> return $ "application"//"octet-stream"

957+ Nothing -> return $ "application" Media.// "octet-stream"

845958 Just t -> case parseAccept t of

846959 Nothing -> throwClientError $ InvalidContentTypeHeader response

847960 Just t' -> return t'

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

@@ -7,6 +7,9 @@ module Servant.Client.Core.Reexport

77 HasClient(..)

88 , foldMapUnion

99 , matchUnion

10+ , AsClientT

11+ , (//)

12+ , (/:)

1013

1114 -- * Response (for @Raw@)

1215 , Response

@@ -23,6 +26,7 @@ module Servant.Client.Core.Reexport

2326 , showBaseUrl

2427 , parseBaseUrl

2528 , InvalidBaseUrlException

29+

2630 ) where

2731

2832

servant-client-core/src/Servant/Client/Generic.hs+8−11

@@ -1,9 +1,10 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeFamilies #-}

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

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeFamilies #-}

7+

78module Servant.Client.Generic (

89 AsClientT,

910 genericClient,

@@ -15,11 +16,7 @@ import Data.Proxy

1516

1617import Servant.API.Generic

1718import Servant.Client.Core

18−

19−-- | A type that specifies that an API record contains a client implementation.

20−data AsClientT (m :: * -> *)

21−instance GenericMode (AsClientT m) where

22− type AsClientT m :- api = Client m api

19+import Servant.Client.Core.HasClient (AsClientT)

2320

2421-- | Generate a record of client functions.

2522genericClient

servant-client/servant-client.cabal+1

@@ -93,6 +93,7 @@ test-suite spec

9393 Servant.ConnectionErrorSpec

9494 Servant.FailSpec

9595 Servant.GenAuthSpec

96+ Servant.GenericSpec

9697 Servant.HoistClientSpec

9798 Servant.StreamSpec

9899 Servant.SuccessSpec

servant-client/test/Servant/ClientTestUtils.hs+23−2

@@ -64,7 +64,8 @@ import Servant.API

6464 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),

6565 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,

6666 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,

67− WithStatus (WithStatus), addHeader)

67+ WithStatus (WithStatus), NamedRoutes, addHeader)

68+import Servant.API.Generic ((:-))

6869import Servant.Client

6970import qualified Servant.Client.Core.Auth as Auth

7071import Servant.Server

@@ -107,6 +108,16 @@ carol = Person "Carol" 17

107108

108109type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

109110

111+data RecordRoutes mode = RecordRoutes

112+ { version :: mode :- "version" :> Get '[JSON] Int

113+ , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String

114+ , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes

115+ } deriving Generic

116+

117+data OtherRoutes mode = OtherRoutes

118+ { something :: mode :- "something" :> Get '[JSON] [String]

119+ } deriving Generic

120+

110121type Api =

111122 Get '[JSON] Person

112123 :<|> "get" :> Get '[JSON] Person

@@ -141,6 +152,7 @@ type Api =

141152 UVerb 'GET '[PlainText] '[WithStatus 200 Person,

142153 WithStatus 301 Text]

143154 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]

155+ :<|> NamedRoutes RecordRoutes

144156

145157

146158api :: Proxy Api

@@ -170,6 +182,7 @@ uverbGetSuccessOrRedirect :: Bool

170182 -> ClientM (Union '[WithStatus 200 Person,

171183 WithStatus 301 Text])

172184uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])

185+recordRoutes :: RecordRoutes (AsClientT ClientM)

173186

174187getRoot

175188 :<|> getGet

@@ -192,7 +205,8 @@ getRoot

192205 :<|> getRedirectWithCookie

193206 :<|> EmptyClient

194207 :<|> uverbGetSuccessOrRedirect

195− :<|> uverbGetCreated = client api

208+ :<|> uverbGetCreated

209+ :<|> recordRoutes = client api

196210

197211server :: Application

198212server = serve api (

@@ -229,6 +243,13 @@ server = serve api (

229243 then respond (WithStatus @301 ("redirecting" :: Text))

230244 else respond (WithStatus @200 alice ))

231245 :<|> respond (WithStatus @201 carol)

246+ :<|> RecordRoutes

247+ { version = pure 42

248+ , echo = pure

249+ , otherRoutes = \_ -> OtherRoutes

250+ { something = pure ["foo", "bar", "pweet"]

251+ }

252+ }

232253 )

233254

234255type FailApi =

servant-client/test/Servant/GenericSpec.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+{-# OPTIONS_GHC -freduction-depth=100 #-}

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

16+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

17+

18+module Servant.GenericSpec (spec) where

19+

20+import Test.Hspec

21+

22+import Servant.Client ((//), (/:))

23+import Servant.ClientTestUtils

24+

25+spec :: Spec

26+spec = describe "Servant.GenericSpec" $ do

27+ genericSpec

28+

29+genericSpec :: Spec

30+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

31+ context "Record clients work as expected" $ do

32+

33+ it "Client functions return expected values" $ \(_,baseUrl) -> do

34+ runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42

35+ runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"

36+ it "Clients can be nested" $ \(_,baseUrl) -> do

37+ runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]

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 >= 0.2 && < 0.14

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+11−18

@@ -1,12 +1,10 @@

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+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeOperators #-}

7+

108-- | @since 0.14.1

119module Servant.Server.Generic (

1210 AsServerT,

@@ -15,21 +13,15 @@ module Servant.Server.Generic (

1513 genericServeT,

1614 genericServeTWithContext,

1715 genericServer,

18− genericServerT,

16+ genericServerT

1917 ) where

2018

2119import Data.Proxy

2220 (Proxy (..))

2321

24−import Servant.API.Generic

2522import Servant.Server

26−

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

28−data AsServerT (m :: * -> *)

29−instance GenericMode (AsServerT m) where

30− type AsServerT m :- api = ServerT api m

31−

32−type AsServer = AsServerT Handler

23+import Servant.API.Generic

24+import Servant.Server.Internal

3325

3426-- | Transform a record of routes into a WAI 'Application'.

3527genericServe

@@ -97,3 +89,4 @@ genericServerT

9789 => routes (AsServerT m)

9890 -> ToServant routes (AsServerT m)

9991genericServerT = toServant

92+

servant-server/src/Servant/Server/Internal.hs+78−15

@@ -1,23 +1,22 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

22{-# LANGUAGE ConstraintKinds #-}

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE DeriveDataTypeable #-}

55{-# LANGUAGE FlexibleContexts #-}

66{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE InstanceSigs #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

89{-# LANGUAGE OverloadedStrings #-}

910{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE QuantifiedConstraints #-}

1012{-# LANGUAGE RankNTypes #-}

1113{-# LANGUAGE ScopedTypeVariables #-}

1214{-# LANGUAGE TupleSections #-}

15+{-# LANGUAGE TypeApplications #-}

1316{-# LANGUAGE TypeFamilies #-}

1417{-# LANGUAGE TypeOperators #-}

1518{-# LANGUAGE UndecidableInstances #-}

1619

17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

18−#define HAS_TYPE_ERROR

19−#endif

20−

2120module Servant.Server.Internal

2221 ( module Servant.Server.Internal

2322 , module Servant.Server.Internal.BasicAuth

@@ -42,6 +41,7 @@ import qualified Data.ByteString as B

4241import qualified Data.ByteString.Builder as BB

4342import qualified Data.ByteString.Char8 as BC8

4443import qualified Data.ByteString.Lazy as BL

44+import Data.Constraint (Dict(..))

4545import Data.Either

4646 (partitionEithers)

4747import Data.Maybe

@@ -54,6 +54,7 @@ import Data.Tagged

5454 (Tagged (..), retag, untag)

5555import qualified Data.Text as T

5656import Data.Typeable

57+import GHC.Generics

5758import GHC.TypeLits

5859 (KnownNat, KnownSymbol, natVal, symbolVal)

5960import qualified Network.HTTP.Media as NHM

@@ -75,7 +76,8 @@ import Servant.API

7576 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

7677 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

7778 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

78− WithNamedContext)

79+ WithNamedContext, NamedRoutes)

80+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

7981import Servant.API.ContentTypes

8082 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

8183 AllMime, MimeRender (..), MimeUnrender (..), NoContent,

@@ -101,12 +103,10 @@ import Servant.Server.Internal.RouteResult

101103import Servant.Server.Internal.RoutingApplication

102104import Servant.Server.Internal.ServerError

103105

104−#ifdef HAS_TYPE_ERROR

105106import GHC.TypeLits

106107 (ErrorMessage (..), TypeError)

107108import Servant.API.TypeLevel

108109 (AtLeastOneFragment, FragmentUnique)

109−#endif

110110

111111class HasServer api context where

112112 type ServerT api (m :: * -> *) :: *

@@ -784,7 +784,7 @@ instance ( KnownSymbol realm

784784-- * helpers

785785

786786ct_wildcard :: B.ByteString

787−ct_wildcard = "*" <> "/" <> "*" -- Because CPP

787+ct_wildcard = "*" <> "/" <> "*"

788788

789789getAcceptHeader :: Request -> AcceptHeader

790790getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders

@@ -815,7 +815,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA

815815-- TypeError helpers

816816-------------------------------------------------------------------------------

817817

818−#ifdef HAS_TYPE_ERROR

819818-- | This instance catches mistakes when there are non-saturated

820819-- type applications on LHS of ':>'.

821820--

@@ -878,7 +877,6 @@ type HasServerArrowTypeError a b =

878877 ':$$: 'ShowType a

879878 ':$$: 'Text "and"

880879 ':$$: 'ShowType b

881−#endif

882880

883881-- | Ignore @'Fragment'@ in server handlers.

884882-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

@@ -891,11 +889,7 @@ type HasServerArrowTypeError a b =

891889-- > server = getBooks

892890-- > where getBooks :: Handler [Book]

893891-- > getBooks = ...return all books...

894−#ifdef HAS_TYPE_ERROR

895892instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)

896−#else

897−instance (HasServer api context)

898−#endif

899893 => HasServer (Fragment a1 :> api) context where

900894 type ServerT (Fragment a1 :> api) m = ServerT api m

901895

@@ -905,3 +899,72 @@ instance (HasServer api context)

905899

906900-- $setup

907901-- >>> import Servant

902+

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

904+data AsServerT (m :: * -> *)

905+instance GenericMode (AsServerT m) where

906+ type AsServerT m :- api = ServerT api m

907+

908+type AsServer = AsServerT Handler

909+

910+

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

912+type GServerConstraints api m =

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

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

915+ )

916+

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

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

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

920+--

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

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

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

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

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

926+--

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

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

929+

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

931+ proof :: Dict (GServerConstraints api m)

932+

933+instance

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

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

936+ ) => GServer api m where

937+ proof = Dict

938+

939+instance

940+ ( HasServer (ToServantApi api) context

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

942+ , forall m. GServer api m

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

944+

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

946+

947+ route

948+ :: Proxy (NamedRoutes api)

949+ -> Context context

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

951+ -> Router env

952+ route _ ctx delayed =

953+ case proof @api @Handler of

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

955+

956+ hoistServerWithContext

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

958+ -> Proxy context

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

960+ -> api (AsServerT m)

961+ -> api (AsServerT n)

962+ hoistServerWithContext _ pctx nat server =

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

964+ (Dict, Dict) ->

965+ fromServant servantSrvN

966+ where

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

968+ toServant server

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

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

servant/servant.cabal+2

@@ -46,6 +46,7 @@ library

4646 Servant.API.HttpVersion

4747 Servant.API.IsSecure

4848 Servant.API.Modifiers

49+ Servant.API.NamedRoutes

4950 Servant.API.QueryParam

5051 Servant.API.Raw

5152 Servant.API.RemoteHost

@@ -80,6 +81,7 @@ library

8081 build-depends:

8182 base >= 4.9 && < 4.16

8283 , bytestring >= 0.10.8.1 && < 0.12

84+ , constraints >= 0.2

8385 , mtl >= 2.2.2 && < 2.3

8486 , sop-core >= 0.4.0.0 && < 0.6

8587 , transformers >= 0.5.2.0 && < 0.6

servant/src/Servant/API.hs+5

@@ -36,6 +36,9 @@ module Servant.API (

3636 module Servant.API.Verbs,

3737 module Servant.API.UVerb,

3838

39+ -- * Sub-APIs defined as records of routes

40+ module Servant.API.NamedRoutes,

41+

3942 -- * Streaming endpoints, distinguished by HTTP method

4043 module Servant.API.Stream,

4144

@@ -130,6 +133,8 @@ import Servant.API.UVerb

130133 Unique, WithStatus (..), inject, statusOf)

131134import Servant.API.Vault

132135 (Vault)

136+import Servant.API.NamedRoutes

137+ (NamedRoutes)

133138import Servant.API.Verbs

134139 (Delete, DeleteAccepted, DeleteNoContent,

135140 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

servant/src/Servant/API/NamedRoutes.hsnew file+10

@@ -0,0 +1,10 @@

1+{-# LANGUAGE KindSignatures #-}

2+{-# OPTIONS_HADDOCK not-home #-}

3+

4+module Servant.API.NamedRoutes (

5+ -- * NamedRoutes combinator

6+ NamedRoutes

7+ ) where

8+

9+-- | Combinator for embedding a record of named routes into a Servant API type.

10+data NamedRoutes (api :: * -> *)

servant/src/Servant/Links.hs+36

@@ -1,13 +1,18 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE FlexibleContexts #-}

45{-# LANGUAGE FlexibleInstances #-}

56{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE InstanceSigs #-}

68{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE QuantifiedConstraints #-}

710{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

812{-# LANGUAGE TypeFamilies #-}

913{-# LANGUAGE TypeOperators #-}

1014{-# LANGUAGE UndecidableInstances #-}

15+

1116{-# OPTIONS_HADDOCK not-home #-}

1217

1318-- | Type safe generation of internal links.

@@ -125,6 +130,7 @@ module Servant.Links (

125130) where

126131

127132import Data.List

133+import Data.Constraint

128134import Data.Proxy

129135 (Proxy (..))

130136import Data.Singletons.Bool

@@ -163,6 +169,8 @@ import Servant.API.IsSecure

163169 (IsSecure)

164170import Servant.API.Modifiers

165171 (FoldRequired)

172+import Servant.API.NamedRoutes

173+ (NamedRoutes)

166174import Servant.API.QueryParam

167175 (QueryFlag, QueryParam', QueryParams)

168176import Servant.API.Raw

@@ -579,6 +587,34 @@ instance HasLink (Stream m status fr ct a) where

579587instance HasLink (UVerb m ct a) where

580588 type MkLink (UVerb m ct a) r = r

581589 toLink toA _ = toA

590+-- Instance for NamedRoutes combinator

591+

592+type GLinkConstraints routes a =

593+ ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)

594+ , GenericServant routes (AsLink a)

595+ )

596+

597+class GLink (routes :: * -> *) (a :: *) where

598+ proof :: Dict (GLinkConstraints routes a)

599+

600+instance GLinkConstraints routes a => GLink routes a where

601+ proof = Dict

602+

603+instance

604+ ( HasLink (ToServantApi routes)

605+ , forall a. GLink routes a

606+ ) => HasLink (NamedRoutes routes) where

607+

608+ type MkLink (NamedRoutes routes) a = routes (AsLink a)

609+

610+ toLink

611+ :: forall a. (Link -> a)

612+ -> Proxy (NamedRoutes routes)

613+ -> Link

614+ -> routes (AsLink a)

615+

616+ toLink toA _ l = case proof @routes @a of

617+ Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l

582618

583619-- AuthProtext instances

584620instance HasLink sub => HasLink (AuthProtect tag :> sub) where