1bb0282 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #1388 from gdeest/generic-apis

1bb0282Gaël Deest5 years ago

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

compare with master

unifiedsplit

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

52 build-depends:

53 base >= 4.9 && < 4.16

54 , bytestring >= 0.10.8.1 && < 0.12

55+ , constraints >= 0.2 && < 0.14

55 , containers >= 0.5.7.1 && < 0.7

56 , containers >= 0.5.7.1 && < 0.7

56 , deepseq >= 1.4.2.0 && < 1.5

57 , deepseq >= 1.4.2.0 && < 1.5

57 , text >= 1.2.3.0 && < 1.3

58 , text >= 1.2.3.0 && < 1.3

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

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

1{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

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

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE QuantifiedConstraints #-}

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TypeApplications #-}

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

14{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE UndecidableInstances #-}

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

18−#define HAS_TYPE_ERROR

19−#endif

20−

21module Servant.Client.Core.HasClient (

17module Servant.Client.Core.HasClient (

22 clientIn,

18 clientIn,

23 HasClient (..),

19 HasClient (..),

24 EmptyClient (..),

20 EmptyClient (..),

21+ AsClientT,

22+ (//),

23+ (/:),

25 foldMapUnion,

24 foldMapUnion,

26 matchUnion,

25 matchUnion,

27 ) where

26 ) where

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

39import qualified Data.ByteString.Lazy as BL

38import qualified Data.ByteString.Lazy as BL

40import Data.Either

39import Data.Either

41 (partitionEithers)

40 (partitionEithers)

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

42import Data.Foldable

43 (toList)

44import Data.List

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

47 (fromList)

48import qualified Data.Text as T

49import Network.HTTP.Media

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

50+ (MediaType, matches, parseAccept)

51+import qualified Network.HTTP.Media as Media

51import qualified Data.Sequence as Seq

52import qualified Data.Sequence as Seq

52import Data.SOP.BasicFunctors

53import Data.SOP.BasicFunctors

53 (I (I), (:.:) (Comp))

54 (I (I), (:.:) (Comp))

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

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

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

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

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

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

82 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)

83import Servant.API.ContentTypes

87import Servant.API.ContentTypes

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

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

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

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

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

792-- > getBooks = client myApi

796-- > getBooks = client myApi

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

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

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

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

795−#ifdef HAS_TYPE_ERROR

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

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

797−#else

798−instance ( HasClient m api

799−#endif

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

801

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

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

816 hoistClientMonad pm _ f cl = \bauth ->

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

818

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

819

932

820

933

821{- Note [Non-Empty Content Types]

934{- Note [Non-Empty Content Types]

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

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

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

842checkContentTypeHeader response =

955checkContentTypeHeader response =

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

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

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

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

845 Just t -> case parseAccept t of

958 Just t -> case parseAccept t of

846 Nothing -> throwClientError $ InvalidContentTypeHeader response

959 Nothing -> throwClientError $ InvalidContentTypeHeader response

847 Just t' -> return t'

960 Just t' -> return t'

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

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

7 HasClient(..)

8 , foldMapUnion

9 , matchUnion

10+ , AsClientT

11+ , (//)

12+ , (/:)

11 -- * Response (for @Raw@)

14 -- * Response (for @Raw@)

12 , Response

15 , Response

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

23 , showBaseUrl

26 , showBaseUrl

24 , parseBaseUrl

27 , parseBaseUrl

25 , InvalidBaseUrlException

28 , InvalidBaseUrlException

29+

26 ) where

30 ) where

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

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

1−{-# LANGUAGE ConstraintKinds #-}

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

2−{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeFamilies #-}

7module Servant.Client.Generic (

8module Servant.Client.Generic (

8 AsClientT,

9 AsClientT,

9 genericClient,

10 genericClient,

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

16import Servant.API.Generic

17import Servant.API.Generic

17import Servant.Client.Core

18import Servant.Client.Core

18−

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

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

24-- | Generate a record of client functions.

21-- | Generate a record of client functions.

25genericClient

22genericClient

servant-client/servant-client.cabal+1

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

93 Servant.ConnectionErrorSpec

94 Servant.FailSpec

95 Servant.GenAuthSpec

96+ Servant.GenericSpec

96 Servant.HoistClientSpec

97 Servant.HoistClientSpec

97 Servant.StreamSpec

98 Servant.StreamSpec

98 Servant.SuccessSpec

99 Servant.SuccessSpec

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

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

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

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

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

67− WithStatus (WithStatus), addHeader)

67+ WithStatus (WithStatus), NamedRoutes, addHeader)

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

68import Servant.Client

69import Servant.Client

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

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

70import Servant.Server

71import Servant.Server

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

107

108

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

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

109

110

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+

110type Api =

121type Api =

111 Get '[JSON] Person

122 Get '[JSON] Person

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

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

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

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

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

142 WithStatus 301 Text]

153 WithStatus 301 Text]

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

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

155+ :<|> NamedRoutes RecordRoutes

144

156

145

157

146api :: Proxy Api

158api :: Proxy Api

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

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

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

171 WithStatus 301 Text])

183 WithStatus 301 Text])

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

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

185+recordRoutes :: RecordRoutes (AsClientT ClientM)

173

186

174getRoot

187getRoot

175 :<|> getGet

188 :<|> getGet

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

192 :<|> getRedirectWithCookie

205 :<|> getRedirectWithCookie

193 :<|> EmptyClient

206 :<|> EmptyClient

194 :<|> uverbGetSuccessOrRedirect

207 :<|> uverbGetSuccessOrRedirect

195− :<|> uverbGetCreated = client api

208+ :<|> uverbGetCreated

209+ :<|> recordRoutes = client api

196

210

197server :: Application

211server :: Application

198server = serve api (

212server = serve api (

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

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

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

230 else respond (WithStatus @200 alice ))

244 else respond (WithStatus @200 alice ))

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

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

246+ :<|> RecordRoutes

247+ { version = pure 42

248+ , echo = pure

249+ , otherRoutes = \_ -> OtherRoutes

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

251+ }

252+ }

232 )

253 )

233

254

234type FailApi =

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

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

16import Network.Wai.Handler.Warp

17import Network.Wai.Handler.Warp

18import Servant

19import Servant

20+import Servant.Server.Generic ()

21+import Servant.API.Generic

20-- * Example

23-- * Example

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

38 -- DELETE /greet/:greetid

41 -- DELETE /greet/:greetid

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

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

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+

41testApi :: Proxy TestApi

52testApi :: Proxy TestApi

42testApi = Proxy

53testApi = Proxy

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

48--

59--

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

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

50server :: Server TestApi

61server :: 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

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

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

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

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

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

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

servant-server/servant-server.cabal+1

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

62 build-depends:

63 base >= 4.9 && < 4.16

64 , bytestring >= 0.10.8.1 && < 0.12

65+ , constraints >= 0.2 && < 0.14

65 , containers >= 0.5.7.1 && < 0.7

66 , containers >= 0.5.7.1 && < 0.7

66 , mtl >= 2.2.2 && < 2.3

67 , mtl >= 2.2.2 && < 2.3

67 , text >= 1.2.3.0 && < 1.3

68 , 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 #-}

1+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeOperators #-}

9−{-# LANGUAGE UndecidableInstances #-}

10-- | @since 0.14.1

8-- | @since 0.14.1

11module Servant.Server.Generic (

9module Servant.Server.Generic (

12 AsServerT,

10 AsServerT,

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

15 genericServeT,

13 genericServeT,

16 genericServeTWithContext,

14 genericServeTWithContext,

17 genericServer,

15 genericServer,

18− genericServerT,

16+ genericServerT

19 ) where

17 ) where

21import Data.Proxy

19import Data.Proxy

22 (Proxy (..))

20 (Proxy (..))

24−import Servant.API.Generic

25import Servant.Server

22import Servant.Server

26−

23+import Servant.API.Generic

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

24+import Servant.Server.Internal

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

29−instance GenericMode (AsServerT m) where

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

31−

32−type AsServer = AsServerT Handler

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

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

35genericServe

27genericServe

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

97 => routes (AsServerT m)

89 => routes (AsServerT m)

98 -> ToServant routes (AsServerT m)

90 -> ToServant routes (AsServerT m)

99genericServerT = toServant

91genericServerT = toServant

92+

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

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DeriveDataTypeable #-}

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE InstanceSigs #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE QuantifiedConstraints #-}

10{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TupleSections #-}

14{-# LANGUAGE TupleSections #-}

15+{-# LANGUAGE TypeApplications #-}

13{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

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

18−#define HAS_TYPE_ERROR

19−#endif

20−

21module Servant.Server.Internal

20module Servant.Server.Internal

22 ( module Servant.Server.Internal

21 ( module Servant.Server.Internal

23 , module Servant.Server.Internal.BasicAuth

22 , module Servant.Server.Internal.BasicAuth

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

42import qualified Data.ByteString.Builder as BB

41import qualified Data.ByteString.Builder as BB

43import qualified Data.ByteString.Char8 as BC8

42import qualified Data.ByteString.Char8 as BC8

44import qualified Data.ByteString.Lazy as BL

43import qualified Data.ByteString.Lazy as BL

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

45import Data.Either

46 (partitionEithers)

47import Data.Maybe

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

54 (Tagged (..), retag, untag)

55import qualified Data.Text as T

56import Data.Typeable

57+import GHC.Generics

57import GHC.TypeLits

58import GHC.TypeLits

58 (KnownNat, KnownSymbol, natVal, symbolVal)

59 (KnownNat, KnownSymbol, natVal, symbolVal)

59import qualified Network.HTTP.Media as NHM

60import qualified Network.HTTP.Media as NHM

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

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

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

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

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

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

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

78− WithNamedContext)

79+ WithNamedContext, NamedRoutes)

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

79import Servant.API.ContentTypes

81import Servant.API.ContentTypes

80 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

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

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

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

101import Servant.Server.Internal.RoutingApplication

103import Servant.Server.Internal.RoutingApplication

102import Servant.Server.Internal.ServerError

104import Servant.Server.Internal.ServerError

103

105

104−#ifdef HAS_TYPE_ERROR

105import GHC.TypeLits

106import GHC.TypeLits

106 (ErrorMessage (..), TypeError)

107 (ErrorMessage (..), TypeError)

107import Servant.API.TypeLevel

108import Servant.API.TypeLevel

108 (AtLeastOneFragment, FragmentUnique)

109 (AtLeastOneFragment, FragmentUnique)

109−#endif

110

111class HasServer api context where

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

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

784-- * helpers

785

786ct_wildcard :: B.ByteString

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

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

788

789getAcceptHeader :: Request -> AcceptHeader

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

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

815-- TypeError helpers

816-------------------------------------------------------------------------------

817

818−#ifdef HAS_TYPE_ERROR

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

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

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

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

821--

820--

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

878 ':$$: 'ShowType a

877 ':$$: 'ShowType a

879 ':$$: 'Text "and"

878 ':$$: 'Text "and"

880 ':$$: 'ShowType b

879 ':$$: 'ShowType b

881−#endif

882

880

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

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

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

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

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

891-- > server = getBooks

889-- > server = getBooks

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

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

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

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

894−#ifdef HAS_TYPE_ERROR

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

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

896−#else

897−instance (HasServer api context)

898−#endif

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

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

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

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

901

895

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

905

899

906-- $setup

900-- $setup

907-- >>> import Servant

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

46 Servant.API.HttpVersion

47 Servant.API.IsSecure

48 Servant.API.Modifiers

49+ Servant.API.NamedRoutes

49 Servant.API.QueryParam

50 Servant.API.QueryParam

50 Servant.API.Raw

51 Servant.API.Raw

51 Servant.API.RemoteHost

52 Servant.API.RemoteHost

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

80 build-depends:

81 build-depends:

81 base >= 4.9 && < 4.16

82 base >= 4.9 && < 4.16

82 , bytestring >= 0.10.8.1 && < 0.12

83 , bytestring >= 0.10.8.1 && < 0.12

84+ , constraints >= 0.2

83 , mtl >= 2.2.2 && < 2.3

85 , mtl >= 2.2.2 && < 2.3

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

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

85 , transformers >= 0.5.2.0 && < 0.6

87 , transformers >= 0.5.2.0 && < 0.6

servant/src/Servant/API.hs+5

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

36 module Servant.API.Verbs,

37 module Servant.API.UVerb,

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

40+ module Servant.API.NamedRoutes,

41+

39 -- * Streaming endpoints, distinguished by HTTP method

42 -- * Streaming endpoints, distinguished by HTTP method

40 module Servant.API.Stream,

43 module Servant.API.Stream,

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

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

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

131import Servant.API.Vault

134import Servant.API.Vault

132 (Vault)

135 (Vault)

136+import Servant.API.NamedRoutes

137+ (NamedRoutes)

133import Servant.API.Verbs

138import Servant.API.Verbs

134 (Delete, DeleteAccepted, DeleteNoContent,

139 (Delete, DeleteAccepted, DeleteNoContent,

135 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

140 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

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

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

1+{-# LANGUAGE KindSignatures #-}

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

4+module Servant.API.NamedRoutes (

5+ -- * NamedRoutes combinator

6+ NamedRoutes

7+ ) where

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 #-}

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE InstanceSigs #-}

6{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE QuantifiedConstraints #-}

7{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

8{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

15+

11{-# OPTIONS_HADDOCK not-home #-}

16{-# OPTIONS_HADDOCK not-home #-}

13-- | Type safe generation of internal links.

18-- | Type safe generation of internal links.

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

125) where

130) where

126

131

127import Data.List

132import Data.List

133+import Data.Constraint

128import Data.Proxy

134import Data.Proxy

129 (Proxy (..))

135 (Proxy (..))

130import Data.Singletons.Bool

136import Data.Singletons.Bool

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

163 (IsSecure)

169 (IsSecure)

164import Servant.API.Modifiers

170import Servant.API.Modifiers

165 (FoldRequired)

171 (FoldRequired)

172+import Servant.API.NamedRoutes

173+ (NamedRoutes)

166import Servant.API.QueryParam

174import Servant.API.QueryParam

167 (QueryFlag, QueryParam', QueryParams)

175 (QueryFlag, QueryParam', QueryParams)

168import Servant.API.Raw

176import Servant.API.Raw

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

579instance HasLink (UVerb m ct a) where

587instance HasLink (UVerb m ct a) where

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

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

581 toLink toA _ = toA

589 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

582

618

583-- AuthProtext instances

619-- AuthProtext instances

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

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