From 65e3070cacccb02502e8c24b3222a0532e3f4397 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 30 Sep 2021 18:16:47 +0200 Subject: [PATCH 01/10] Add NamedRoutes combinator MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Allows users to directly embed APIs defined as records of routes into vanilla Servant API types. E.g.: ```haskell data MyRoutes mode = MyRoutes { version :: mode :- Get '[JSON] Int , … } type API = "prefix" :> NamedRoutes MyRoutes :<|> … ``` APIs can thus be recursively defined directly with Generic record types. --- servant/src/Servant/API/Generic.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/servant/src/Servant/API/Generic.hs b/servant/src/Servant/API/Generic.hs index b887c09e..6262e539 100644 --- a/servant/src/Servant/API/Generic.hs +++ b/servant/src/Servant/API/Generic.hs @@ -37,6 +37,8 @@ module Servant.API.Generic ( ToServant, toServant, fromServant, + -- * NamedRoutes combinator + NamedRoutes, -- * AsApi AsApi, ToServantApi, @@ -120,6 +122,9 @@ genericApi -> Proxy (ToServantApi routes) genericApi _ = Proxy +-- | Combinator for embedding a record of named routes into a Servant API type. +data NamedRoutes (api :: * -> *) + ------------------------------------------------------------------------------- -- Class ------------------------------------------------------------------------------- From b0b02f194805372018deb4592da57ea25a35486a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 30 Sep 2021 18:39:41 +0200 Subject: [PATCH 02/10] Implement `HasServer (NamedRoutes routes)` MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We define `ServerT (NamedRoutes api) m` as `api (AsServerT m)`, so that the server of an record-defined API is a record of handlers. The implementation piggy backs on the instance for “vanilla” servant types with `(:<|>)`, using the `GServantProduct` for converting backd and forth between the record / vanilla servers. The main difficulty is that GHC needs to know that this operation is legit, which can be expressed as the fact that: ``` GToServant (Rep (ServerT (NamedRoutes api))) m ~ ServerT (GToServant (Rep (api AsApi))) m ``` plus a few additional constraints. This is easy enough for `route`, as we know that `m ~ Handler`. But in the case of `hoistServerWithContext`, the two involved monads are unknown ; in other words, this constraint needs to hold `forall m.` Switching `-XQuantifiedConstraints` on is not sufficient, as our constraints involve type families (`Rep` and `ServerT`). Our trick is to use an intermediary typeclass, `GServer`, as a provider of evidence (in the form of a `Dict`) that our constraints are indeed satisfied for a particular monad. The only instance of `GServer` is defined along with it, so it is practically invisible to users. --- servant-server/example/greet.hs | 19 +++- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server/Generic.hs | 94 ++++++++++++++++++-- 3 files changed, 103 insertions(+), 11 deletions(-) diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index e354351f..5d95ddca 100644 --- a/servant-server/example/greet.hs +++ b/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 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 86e00d31..709772f0 100644 --- a/servant-server/servant-server.cabal +++ b/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 , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3 , text >= 1.2.3.0 && < 1.3 diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index c3db01c3..c4a6f934 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -1,12 +1,20 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, @@ -16,13 +24,20 @@ module Servant.Server.Generic ( genericServeTWithContext, genericServer, genericServerT, + -- * Internal machinery + GServerConstraints, + GServer, + -- * Re-exports + NamedRoutes ) where +import Data.Constraint import Data.Proxy (Proxy (..)) import Servant.API.Generic import Servant.Server +import Servant.Server.Internal -- | A type that specifies that an API record contains a server implementation. data AsServerT (m :: * -> *) @@ -97,3 +112,64 @@ genericServerT => routes (AsServerT m) -> ToServant routes (AsServerT m) genericServerT = toServant + +-- | 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 From 5ead291f8dc70e51cabf00e24e3ccc901bfbcfc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Fri, 1 Oct 2021 02:24:21 +0200 Subject: [PATCH 03/10] Implementation of HasClient Follows the same design as `HasServer` in the previous commit. A test has been added (which incidentally acts as a test for the HasServer instance). --- servant-client-core/servant-client-core.cabal | 1 + .../src/Servant/Client/Generic.hs | 58 +++++++++++++++++-- servant-client/servant-client.cabal | 1 + .../test/Servant/ClientTestUtils.hs | 24 +++++++- servant-client/test/Servant/GenericSpec.hs | 37 ++++++++++++ 5 files changed, 114 insertions(+), 7 deletions(-) create mode 100644 servant-client/test/Servant/GenericSpec.hs diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 3d630110..118908c5 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/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 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , text >= 1.2.3.0 && < 1.3 diff --git a/servant-client-core/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Generic.hs index 836c6599..aee599d4 100644 --- a/servant-client-core/src/Servant/Client/Generic.hs +++ b/servant-client-core/src/Servant/Client/Generic.hs @@ -1,15 +1,23 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Client.Generic ( AsClientT, genericClient, genericClientHoist, ) where +import Data.Constraint (Dict(..)) import Data.Proxy (Proxy (..)) @@ -49,3 +57,41 @@ genericClientHoist nt where m = Proxy :: Proxy m api = Proxy :: Proxy (ToServantApi routes) + +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 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 3ca4c88a..3c3de1a4 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 198c6462..aedc3f91 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -65,9 +65,12 @@ import Servant.API NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union, WithStatus (WithStatus), addHeader) +import Servant.API.Generic import Servant.Client +import Servant.Client.Generic import qualified Servant.Client.Core.Auth as Auth import Servant.Server +import Servant.Server.Generic import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI @@ -107,6 +110,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" :> 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 +154,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 @@ -192,7 +206,8 @@ getRoot :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect - :<|> uverbGetCreated = client api + :<|> uverbGetCreated + :<|> recordRoutes = client api server :: Application server = serve api ( @@ -229,6 +244,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 = diff --git a/servant-client/test/Servant/GenericSpec.hs b/servant-client/test/Servant/GenericSpec.hs new file mode 100644 index 00000000..9ce4f4a4 --- /dev/null +++ b/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 Data.Function ((&)) +import Test.Hspec + +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 & something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] From 861cd4f997ee454d8a3d575db200260faa7293c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Sat, 2 Oct 2021 17:32:41 +0200 Subject: [PATCH 04/10] Exclude quantified constraints code for GHCJS QuantifiedConstraints isn't available for GHC 8.4 (where our GHCJS version is still stuck). We may need to take a drastic decision for GHCJS at some point. --- servant-client-core/src/Servant/Client/Generic.hs | 11 ++++++++++- servant-server/src/Servant/Server/Generic.hs | 10 ++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/servant-client-core/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Generic.hs index aee599d4..8452df42 100644 --- a/servant-client-core/src/Servant/Client/Generic.hs +++ b/servant-client-core/src/Servant/Client/Generic.hs @@ -1,16 +1,21 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif + module Servant.Client.Generic ( AsClientT, genericClient, @@ -58,6 +63,8 @@ genericClientHoist nt m = Proxy :: Proxy m api = Proxy :: Proxy (ToServantApi routes) +#if __GLASGOW_HASKELL__ >= 806 + type GClientConstraints api m = ( GenericServant api (AsClientT m) , Client m (ToServantApi api) ~ ToServant api (AsClientT m) @@ -95,3 +102,5 @@ instance fromServant @api @(AsClientT mb) $ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $ toServant @api @(AsClientT ma) clientA + +#endif diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index c4a6f934..65343ed3 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,6 +16,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif + -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, @@ -113,6 +119,8 @@ genericServerT -> ToServant routes (AsServerT m) genericServerT = toServant +#if __GLASGOW_HASKELL__ >= 806 + -- | Set of constraints required to convert to / from vanilla server types. type GServerConstraints api m = ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m @@ -173,3 +181,5 @@ instance toServant server servantSrvN :: ServerT (ToServantApi api) n = hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM + +#endif From b033871dfcc7878d3a6d01d99674061da317a8fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Sat, 2 Oct 2021 20:43:38 +0200 Subject: [PATCH 05/10] Implement HasLink instance for NamedRoutes --- servant/servant.cabal | 1 + servant/src/Servant/Links.hs | 40 ++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/servant/servant.cabal b/servant/servant.cabal index 41ea5792..18a818b3 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -80,6 +80,7 @@ library build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 + , constraints , mtl >= 2.2.2 && < 2.3 , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6 diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 50a7ee57..e7ef257d 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -1,13 +1,22 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif + {-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links. @@ -125,6 +134,7 @@ module Servant.Links ( ) where import Data.List +import Data.Constraint import Data.Proxy (Proxy (..)) import Data.Singletons.Bool @@ -579,6 +589,36 @@ 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 + +#if __GLASGOW_HASKELL__ >= 806 +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 +#endif -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where From fca59556dd5cd196f0ed521beef89ce774e15aea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Sun, 3 Oct 2021 17:09:46 +0200 Subject: [PATCH 06/10] Code reorganization Move `HasServer (NamedRoutes routes)` instance The instance has been moved to `Servant.Server.Internal`, as the instances for other combinators. It is necessary so that the instance can be re-exported from `Servant.Server` without circular imports. Otherwise, users have to import `Servant.Server.Generic` manually ; forgetting to do so will produce confusing error messages about the missing instance. Move `HasClient (NamedRoutes routes)` instance Moved so that the instance is made available when importing `Servant.Client`, avoiding possibly confusing errors when `Servant.Client.Generic` isn't imported. --- .../src/Servant/Client/Core/HasClient.hs | 57 ++++++++++- .../src/Servant/Client/Generic.hs | 60 +----------- servant-server/src/Servant/Server/Generic.hs | 97 +------------------ servant-server/src/Servant/Server/Internal.hs | 85 +++++++++++++++- servant/servant.cabal | 3 +- servant/src/Servant/API.hs | 5 + servant/src/Servant/API/Generic.hs | 5 - servant/src/Servant/API/NamedRoutes.hs | 10 ++ servant/src/Servant/Links.hs | 2 + 9 files changed, 162 insertions(+), 162 deletions(-) create mode 100644 servant/src/Servant/API/NamedRoutes.hs diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index d598bf66..11e7407e 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -18,10 +18,15 @@ #define HAS_TYPE_ERROR #endif +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif + module Servant.Client.Core.HasClient ( clientIn, HasClient (..), EmptyClient (..), + AsClientT, foldMapUnion, matchUnion, ) where @@ -39,6 +44,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 @@ -79,7 +85,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) @@ -816,6 +825,52 @@ 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 + +#if __GLASGOW_HASKELL__ >= 806 + +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 + +#endif {- Note [Non-Empty Content Types] diff --git a/servant-client-core/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Generic.hs index 8452df42..e771edae 100644 --- a/servant-client-core/src/Servant/Client/Generic.hs +++ b/servant-client-core/src/Servant/Client/Generic.hs @@ -1,20 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE QuantifiedConstraints #-} -#endif module Servant.Client.Generic ( AsClientT, @@ -22,17 +11,12 @@ module Servant.Client.Generic ( genericClientHoist, ) where -import Data.Constraint (Dict(..)) import Data.Proxy (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 @@ -62,45 +46,3 @@ genericClientHoist nt where m = Proxy :: Proxy m api = Proxy :: Proxy (ToServantApi routes) - -#if __GLASGOW_HASKELL__ >= 806 - -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 - -#endif diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index 65343ed3..9aed4b99 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -1,25 +1,9 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE QuantifiedConstraints #-} -#endif -- | @since 0.14.1 module Servant.Server.Generic ( @@ -29,29 +13,16 @@ module Servant.Server.Generic ( genericServeT, genericServeTWithContext, genericServer, - genericServerT, - -- * Internal machinery - GServerConstraints, - GServer, - -- * Re-exports - NamedRoutes + genericServerT ) where -import Data.Constraint import Data.Proxy (Proxy (..)) -import Servant.API.Generic import Servant.Server +import Servant.API.Generic import Servant.Server.Internal --- | 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 - -- | Transform a record of routes into a WAI 'Application'. genericServe :: forall routes. @@ -119,67 +90,3 @@ genericServerT -> ToServant routes (AsServerT m) genericServerT = toServant -#if __GLASGOW_HASKELL__ >= 806 - --- | 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 - -#endif diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index e15102e0..206f05ff 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,15 +1,18 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,6 +21,10 @@ #define HAS_TYPE_ERROR #endif +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif + module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth @@ -42,6 +49,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 +62,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 +84,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, @@ -905,3 +915,76 @@ 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 + + +#if __GLASGOW_HASKELL__ >= 806 + +-- | 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 + +#endif diff --git a/servant/servant.cabal b/servant/servant.cabal index 18a818b3..f2e7359f 100644 --- a/servant/servant.cabal +++ b/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,7 +81,7 @@ library build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 - , constraints + , constraints >= 0.2 , mtl >= 2.2.2 && < 2.3 , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index deb974ae..de4b805c 100644 --- a/servant/src/Servant/API.hs +++ b/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, diff --git a/servant/src/Servant/API/Generic.hs b/servant/src/Servant/API/Generic.hs index 6262e539..b887c09e 100644 --- a/servant/src/Servant/API/Generic.hs +++ b/servant/src/Servant/API/Generic.hs @@ -37,8 +37,6 @@ module Servant.API.Generic ( ToServant, toServant, fromServant, - -- * NamedRoutes combinator - NamedRoutes, -- * AsApi AsApi, ToServantApi, @@ -122,9 +120,6 @@ genericApi -> Proxy (ToServantApi routes) genericApi _ = Proxy --- | Combinator for embedding a record of named routes into a Servant API type. -data NamedRoutes (api :: * -> *) - ------------------------------------------------------------------------------- -- Class ------------------------------------------------------------------------------- diff --git a/servant/src/Servant/API/NamedRoutes.hs b/servant/src/Servant/API/NamedRoutes.hs new file mode 100644 index 00000000..eefbe6d3 --- /dev/null +++ b/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 :: * -> *) diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index e7ef257d..8b2fc690 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -173,6 +173,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 From 5f8aaec1460508d1b5963eb18fdbf188bee4eeb4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 4 Oct 2021 14:01:11 +0200 Subject: [PATCH 07/10] Fix client tests --- servant-client-core/src/Servant/Client/Core/Reexport.hs | 2 ++ servant-client/test/Servant/ClientTestUtils.hs | 7 +++---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 7d2aa980..32c03eca 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -7,6 +7,7 @@ module Servant.Client.Core.Reexport HasClient(..) , foldMapUnion , matchUnion + , AsClientT -- * Response (for @Raw@) , Response @@ -23,6 +24,7 @@ module Servant.Client.Core.Reexport , showBaseUrl , parseBaseUrl , InvalidBaseUrlException + ) where diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index aedc3f91..944c9614 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -64,13 +64,11 @@ 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) -import Servant.API.Generic + WithStatus (WithStatus), NamedRoutes, addHeader) +import Servant.API.Generic ((:-)) import Servant.Client -import Servant.Client.Generic import qualified Servant.Client.Core.Auth as Auth import Servant.Server -import Servant.Server.Generic import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI @@ -184,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 From 6718752b4a94d3c14b58d87a32c73b556c949ad4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 4 Oct 2021 16:11:27 +0200 Subject: [PATCH 08/10] Add (/:) operator --- .../src/Servant/Client/Core/HasClient.hs | 32 +++++++++++++++++++ .../src/Servant/Client/Core/Reexport.hs | 1 + servant-client/test/Servant/GenericSpec.hs | 8 ++--- 3 files changed, 37 insertions(+), 4 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 11e7407e..a7573e5c 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -27,6 +27,7 @@ module Servant.Client.Core.HasClient ( HasClient (..), EmptyClient (..), AsClientT, + (/:), foldMapUnion, matchUnion, ) where @@ -872,6 +873,37 @@ instance #endif +infixl 1 /: + +-- | Convenience function for working with nested record-clients. +-- +-- Example: +-- +-- @@ +-- type Api = NamedAPI RootApi +-- +-- data RootApi mode = RootApi +-- { subApi :: mode :- NamedAPI SubApi +-- , … +-- } deriving Generic +-- +-- data SubAmi 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 + {- Note [Non-Empty Content Types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 32c03eca..788e44b4 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -8,6 +8,7 @@ module Servant.Client.Core.Reexport , foldMapUnion , matchUnion , AsClientT + , (/:) -- * Response (for @Raw@) , Response diff --git a/servant-client/test/Servant/GenericSpec.hs b/servant-client/test/Servant/GenericSpec.hs index 9ce4f4a4..b347cf57 100644 --- a/servant-client/test/Servant/GenericSpec.hs +++ b/servant-client/test/Servant/GenericSpec.hs @@ -17,9 +17,9 @@ module Servant.GenericSpec (spec) where -import Data.Function ((&)) import Test.Hspec +import Servant.Client ((/:)) import Servant.ClientTestUtils spec :: Spec @@ -31,7 +31,7 @@ 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" + 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 & something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] + runClient (recordRoutes /: otherRoutes /: something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] From d81c8d99119d4cb896c59d81a98a37798b6aaa6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Fri, 8 Oct 2021 15:45:18 +0200 Subject: [PATCH 09/10] Add parameter-supplying operator Renamed `(/:)` to `(//)`, and used `(/:)` for supplying parameters to client functions. Should close #1442. --- .../src/Servant/Client/Core/HasClient.hs | 55 ++++++++++++++++--- .../src/Servant/Client/Core/Reexport.hs | 1 + .../test/Servant/ClientTestUtils.hs | 4 +- servant-client/test/Servant/GenericSpec.hs | 8 +-- 4 files changed, 55 insertions(+), 13 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index a7573e5c..6f1f08eb 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -27,6 +27,7 @@ module Servant.Client.Core.HasClient ( HasClient (..), EmptyClient (..), AsClientT, + (//), (/:), foldMapUnion, matchUnion, @@ -54,7 +55,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)) @@ -873,9 +875,12 @@ instance #endif -infixl 1 /: +infixl 1 // +infixl 2 /: --- | Convenience function for working with nested record-clients. +-- | Helper to make code using records of clients more readable. +-- +-- Can be mixed with (/:) for supplying arguments. -- -- Example: -- @@ -899,10 +904,46 @@ infixl 1 /: -- rootClient = client api -- -- endpointClient :: ClientM Person --- endpointClient = client /: subApi /: endpoint +-- endpointClient = client // subApi // endpoint -- @@ -(/:) :: a -> (a -> b) -> b -x /: f = f x +(//) :: 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 use in conjunction with '(//)'. +-- +-- Example: +-- +-- @@ +-- type Api = NamedAPI RootApi +-- +-- data RootApi mode = RootApi +-- { subApi :: mode :- Capture "token" String :> NamedAPI SubApi +-- , hello :: mode :- Capture "name" String :> Get '[JSON] String +-- , … +-- } deriving Generic +-- +-- data SubAmi 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] @@ -928,7 +969,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' diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 788e44b4..e7f43f71 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -8,6 +8,7 @@ module Servant.Client.Core.Reexport , foldMapUnion , matchUnion , AsClientT + , (//) , (/:) -- * Response (for @Raw@) diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 944c9614..d7f6578f 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -111,7 +111,7 @@ 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" :> NamedRoutes OtherRoutes + , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes } deriving Generic data OtherRoutes mode = OtherRoutes @@ -246,7 +246,7 @@ server = serve api ( :<|> RecordRoutes { version = pure 42 , echo = pure - , otherRoutes = OtherRoutes + , otherRoutes = \_ -> OtherRoutes { something = pure ["foo", "bar", "pweet"] } } diff --git a/servant-client/test/Servant/GenericSpec.hs b/servant-client/test/Servant/GenericSpec.hs index b347cf57..61ab5eb4 100644 --- a/servant-client/test/Servant/GenericSpec.hs +++ b/servant-client/test/Servant/GenericSpec.hs @@ -19,7 +19,7 @@ module Servant.GenericSpec (spec) where import Test.Hspec -import Servant.Client ((/:)) +import Servant.Client ((//), (/:)) import Servant.ClientTestUtils spec :: Spec @@ -31,7 +31,7 @@ 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" + 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 /: something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] + runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] From 575aa70ecad2a725a726178ed352b77f4238e0ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 4 Oct 2021 23:21:12 +0200 Subject: [PATCH 10/10] Cleanup --- servant-client-core/servant-client-core.cabal | 2 +- .../src/Servant/Client/Core/HasClient.hs | 31 +++++-------------- servant-server/servant-server.cabal | 2 +- servant-server/src/Servant/Server/Internal.hs | 24 ++------------ servant/src/Servant/Links.hs | 8 +---- 5 files changed, 13 insertions(+), 54 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 118908c5..808e4185 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -52,7 +52,7 @@ library build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 - , constraints + , 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 diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 6f1f08eb..e25a07b0 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/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,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 -#define HAS_TYPE_ERROR -#endif - -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE QuantifiedConstraints #-} -#endif - module Servant.Client.Core.HasClient ( clientIn, HasClient (..), @@ -804,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 @@ -833,7 +821,6 @@ data AsClientT (m :: * -> *) instance GenericMode (AsClientT m) where type AsClientT m :- api = Client m api -#if __GLASGOW_HASKELL__ >= 806 type GClientConstraints api m = ( GenericServant api (AsClientT m) @@ -873,8 +860,6 @@ instance hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $ toServant @api @(AsClientT ma) clientA -#endif - infixl 1 // infixl 2 /: @@ -885,14 +870,14 @@ infixl 2 /: -- Example: -- -- @@ --- type Api = NamedAPI RootApi +-- type Api = NamedRoutes RootApi -- -- data RootApi mode = RootApi --- { subApi :: mode :- NamedAPI SubApi +-- { subApi :: mode :- NamedRoutes SubApi -- , … -- } deriving Generic -- --- data SubAmi mode = SubApi +-- data SubApi mode = SubApi -- { endpoint :: mode :- Get '[JSON] Person -- , … -- } deriving Generic @@ -912,20 +897,20 @@ x // f = f x -- | Convenience function for supplying arguments to client functions when -- working with records of clients. -- --- Intended to be use in conjunction with '(//)'. +-- Intended to be used in conjunction with '(//)'. -- -- Example: -- -- @@ --- type Api = NamedAPI RootApi +-- type Api = NamedRoutes RootApi -- -- data RootApi mode = RootApi --- { subApi :: mode :- Capture "token" String :> NamedAPI SubApi +-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi -- , hello :: mode :- Capture "name" String :> Get '[JSON] String -- , … -- } deriving Generic -- --- data SubAmi mode = SubApi +-- data SubApi mode = SubApi -- { endpoint :: mode :- Get '[JSON] Person -- , … -- } deriving Generic diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 709772f0..15b63601 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -62,7 +62,7 @@ library build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 - , constraints + , 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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 206f05ff..46cee71d 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -9,6 +8,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -17,14 +17,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 -#define HAS_TYPE_ERROR -#endif - -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE QuantifiedConstraints #-} -#endif - module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth @@ -111,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 :: * -> *) :: * @@ -794,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 @@ -825,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 ':>'. -- @@ -888,7 +877,6 @@ type HasServerArrowTypeError a b = ':$$: 'ShowType a ':$$: 'Text "and" ':$$: 'ShowType b -#endif -- | Ignore @'Fragment'@ in server handlers. -- See for more details. @@ -901,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 @@ -924,8 +908,6 @@ instance GenericMode (AsServerT m) where type AsServer = AsServerT Handler -#if __GLASGOW_HASKELL__ >= 806 - -- | Set of constraints required to convert to / from vanilla server types. type GServerConstraints api m = ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m @@ -986,5 +968,3 @@ instance toServant server servantSrvN :: ServerT (ToServantApi api) n = hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM - -#endif diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 8b2fc690..5a12e2e5 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -1,22 +1,18 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE QuantifiedConstraints #-} -#endif - {-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links. @@ -593,7 +589,6 @@ instance HasLink (UVerb m ct a) where toLink toA _ = toA -- Instance for NamedRoutes combinator -#if __GLASGOW_HASKELL__ >= 806 type GLinkConstraints routes a = ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a) , GenericServant routes (AsLink a) @@ -620,7 +615,6 @@ instance toLink toA _ l = case proof @routes @a of Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l -#endif -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where