diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 3d630110..808e4185 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 >= 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 d598bf66..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,13 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 -#define HAS_TYPE_ERROR -#endif - module Servant.Client.Core.HasClient ( clientIn, HasClient (..), EmptyClient (..), + AsClientT, + (//), + (/:), foldMapUnion, matchUnion, ) where @@ -39,6 +38,7 @@ import Data.ByteString.Builder import qualified Data.ByteString.Lazy as BL import Data.Either (partitionEithers) +import Data.Constraint (Dict(..)) import Data.Foldable (toList) import Data.List @@ -47,7 +47,8 @@ import Data.Sequence (fromList) import qualified Data.Text as T import Network.HTTP.Media - (MediaType, matches, parseAccept, (//)) + (MediaType, matches, parseAccept) +import qualified Network.HTTP.Media as Media import qualified Data.Sequence as Seq import Data.SOP.BasicFunctors (I (I), (:.:) (Comp)) @@ -79,7 +80,10 @@ import Servant.API ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList, - getResponse, toEncodedUrlPiece, toUrlPiece) + getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes) +import Servant.API.Generic + (GenericMode(..), ToServant, ToServantApi + , GenericServant, toServant, fromServant) import Servant.API.ContentTypes (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender)) import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) @@ -792,11 +796,7 @@ instance ( HasClient m api -- > getBooks = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooks' for all books. -#ifdef HAS_TYPE_ERROR instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api -#else -instance ( HasClient m api -#endif ) => HasClient m (Fragment a :> api) where type Client m (Fragment a :> api) = Client m api @@ -816,6 +816,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where hoistClientMonad pm _ f cl = \bauth -> hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) +-- | A type that specifies that an API record contains a client implementation. +data AsClientT (m :: * -> *) +instance GenericMode (AsClientT m) where + type AsClientT m :- api = Client m api + + +type GClientConstraints api m = + ( GenericServant api (AsClientT m) + , Client m (ToServantApi api) ~ ToServant api (AsClientT m) + ) + +class GClient (api :: * -> *) m where + proof :: Dict (GClientConstraints api m) + +instance GClientConstraints api m => GClient api m where + proof = Dict + +instance + ( forall n. GClient api n + , HasClient m (ToServantApi api) + , RunClient m + ) + => HasClient m (NamedRoutes api) where + type Client m (NamedRoutes api) = api (AsClientT m) + + clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api) + clientWithRoute pm _ request = + case proof @api @m of + Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request + + hoistClientMonad + :: forall ma mb. + Proxy m + -> Proxy (NamedRoutes api) + -> (forall x. ma x -> mb x) + -> Client ma (NamedRoutes api) + -> Client mb (NamedRoutes api) + hoistClientMonad _ _ nat clientA = + case (proof @api @ma, proof @api @mb) of + (Dict, Dict) -> + fromServant @api @(AsClientT mb) $ + hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $ + toServant @api @(AsClientT ma) clientA + +infixl 1 // +infixl 2 /: + +-- | Helper to make code using records of clients more readable. +-- +-- Can be mixed with (/:) for supplying arguments. +-- +-- Example: +-- +-- @@ +-- type Api = NamedRoutes RootApi +-- +-- data RootApi mode = RootApi +-- { subApi :: mode :- NamedRoutes SubApi +-- , … +-- } deriving Generic +-- +-- data SubApi mode = SubApi +-- { endpoint :: mode :- Get '[JSON] Person +-- , … +-- } deriving Generic +-- +-- api :: Proxy API +-- api = Proxy +-- +-- rootClient :: RootApi (AsClientT ClientM) +-- rootClient = client api +-- +-- endpointClient :: ClientM Person +-- endpointClient = client // subApi // endpoint +-- @@ +(//) :: a -> (a -> b) -> b +x // f = f x + +-- | Convenience function for supplying arguments to client functions when +-- working with records of clients. +-- +-- Intended to be used in conjunction with '(//)'. +-- +-- Example: +-- +-- @@ +-- type Api = NamedRoutes RootApi +-- +-- data RootApi mode = RootApi +-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi +-- , hello :: mode :- Capture "name" String :> Get '[JSON] String +-- , … +-- } deriving Generic +-- +-- data SubApi mode = SubApi +-- { endpoint :: mode :- Get '[JSON] Person +-- , … +-- } deriving Generic +-- +-- api :: Proxy API +-- api = Proxy +-- +-- rootClient :: RootApi (AsClientT ClientM) +-- rootClient = client api +-- +-- hello :: String -> ClientM String +-- hello name = rootClient // hello /: name +-- +-- endpointClient :: ClientM Person +-- endpointClient = client // subApi /: "foobar123" // endpoint +-- @@ +(/:) :: (a -> b -> c) -> b -> a -> c +(/:) = flip {- Note [Non-Empty Content Types] @@ -841,7 +954,7 @@ for empty and one for non-empty lists). checkContentTypeHeader :: RunClient m => Response -> m MediaType checkContentTypeHeader response = case lookup "Content-Type" $ toList $ responseHeaders response of - Nothing -> return $ "application"//"octet-stream" + Nothing -> return $ "application" Media.// "octet-stream" Just t -> case parseAccept t of Nothing -> throwClientError $ InvalidContentTypeHeader response Just t' -> return t' diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 7d2aa980..e7f43f71 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -7,6 +7,9 @@ module Servant.Client.Core.Reexport HasClient(..) , foldMapUnion , matchUnion + , AsClientT + , (//) + , (/:) -- * Response (for @Raw@) , Response @@ -23,6 +26,7 @@ module Servant.Client.Core.Reexport , showBaseUrl , parseBaseUrl , InvalidBaseUrlException + ) where diff --git a/servant-client-core/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Generic.hs index 836c6599..e771edae 100644 --- a/servant-client-core/src/Servant/Client/Generic.hs +++ b/servant-client-core/src/Servant/Client/Generic.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + module Servant.Client.Generic ( AsClientT, genericClient, @@ -15,11 +16,7 @@ import Data.Proxy import Servant.API.Generic import Servant.Client.Core - --- | A type that specifies that an API record contains a client implementation. -data AsClientT (m :: * -> *) -instance GenericMode (AsClientT m) where - type AsClientT m :- api = Client m api +import Servant.Client.Core.HasClient (AsClientT) -- | Generate a record of client functions. genericClient 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..d7f6578f 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -64,7 +64,8 @@ import Servant.API JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union, - WithStatus (WithStatus), addHeader) + WithStatus (WithStatus), NamedRoutes, addHeader) +import Servant.API.Generic ((:-)) import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server @@ -107,6 +108,16 @@ carol = Person "Carol" 17 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] +data RecordRoutes mode = RecordRoutes + { version :: mode :- "version" :> Get '[JSON] Int + , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String + , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes + } deriving Generic + +data OtherRoutes mode = OtherRoutes + { something :: mode :- "something" :> Get '[JSON] [String] + } deriving Generic + type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person @@ -141,6 +152,7 @@ type Api = UVerb 'GET '[PlainText] '[WithStatus 200 Person, WithStatus 301 Text] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] + :<|> NamedRoutes RecordRoutes api :: Proxy Api @@ -170,6 +182,7 @@ uverbGetSuccessOrRedirect :: Bool -> ClientM (Union '[WithStatus 200 Person, WithStatus 301 Text]) uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) +recordRoutes :: RecordRoutes (AsClientT ClientM) getRoot :<|> getGet @@ -192,7 +205,8 @@ getRoot :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect - :<|> uverbGetCreated = client api + :<|> uverbGetCreated + :<|> recordRoutes = client api server :: Application server = serve api ( @@ -229,6 +243,13 @@ server = serve api ( then respond (WithStatus @301 ("redirecting" :: Text)) else respond (WithStatus @200 alice )) :<|> respond (WithStatus @201 carol) + :<|> RecordRoutes + { version = pure 42 + , echo = pure + , otherRoutes = \_ -> OtherRoutes + { something = pure ["foo", "bar", "pweet"] + } + } ) type FailApi = diff --git a/servant-client/test/Servant/GenericSpec.hs b/servant-client/test/Servant/GenericSpec.hs new file mode 100644 index 00000000..61ab5eb4 --- /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 Test.Hspec + +import Servant.Client ((//), (/:)) +import Servant.ClientTestUtils + +spec :: Spec +spec = describe "Servant.GenericSpec" $ do + genericSpec + +genericSpec :: Spec +genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do + context "Record clients work as expected" $ do + + it "Client functions return expected values" $ \(_,baseUrl) -> do + runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42 + runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo" + it "Clients can be nested" $ \(_,baseUrl) -> do + runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] 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..15b63601 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 >= 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/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index c3db01c3..9aed4b99 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, @@ -15,21 +13,15 @@ module Servant.Server.Generic ( genericServeT, genericServeTWithContext, genericServer, - genericServerT, + genericServerT ) where import Data.Proxy (Proxy (..)) -import Servant.API.Generic import Servant.Server - --- | A type that specifies that an API record contains a server implementation. -data AsServerT (m :: * -> *) -instance GenericMode (AsServerT m) where - type AsServerT m :- api = ServerT api m - -type AsServer = AsServerT Handler +import Servant.API.Generic +import Servant.Server.Internal -- | Transform a record of routes into a WAI 'Application'. genericServe @@ -97,3 +89,4 @@ genericServerT => routes (AsServerT m) -> ToServant routes (AsServerT m) genericServerT = toServant + diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index e15102e0..46cee71d 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 -#define HAS_TYPE_ERROR -#endif - module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth @@ -42,6 +41,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL +import Data.Constraint (Dict(..)) import Data.Either (partitionEithers) import Data.Maybe @@ -54,6 +54,7 @@ import Data.Tagged (Tagged (..), retag, untag) import qualified Data.Text as T import Data.Typeable +import GHC.Generics import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import qualified Network.HTTP.Media as NHM @@ -75,7 +76,8 @@ import Servant.API QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, - WithNamedContext) + WithNamedContext, NamedRoutes) +import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime, MimeRender (..), MimeUnrender (..), NoContent, @@ -101,12 +103,10 @@ import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError -#ifdef HAS_TYPE_ERROR import GHC.TypeLits (ErrorMessage (..), TypeError) import Servant.API.TypeLevel (AtLeastOneFragment, FragmentUnique) -#endif class HasServer api context where type ServerT api (m :: * -> *) :: * @@ -784,7 +784,7 @@ instance ( KnownSymbol realm -- * helpers ct_wildcard :: B.ByteString -ct_wildcard = "*" <> "/" <> "*" -- Because CPP +ct_wildcard = "*" <> "/" <> "*" getAcceptHeader :: Request -> AcceptHeader getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders @@ -815,7 +815,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA -- TypeError helpers ------------------------------------------------------------------------------- -#ifdef HAS_TYPE_ERROR -- | This instance catches mistakes when there are non-saturated -- type applications on LHS of ':>'. -- @@ -878,7 +877,6 @@ type HasServerArrowTypeError a b = ':$$: 'ShowType a ':$$: 'Text "and" ':$$: 'ShowType b -#endif -- | Ignore @'Fragment'@ in server handlers. -- See for more details. @@ -891,11 +889,7 @@ type HasServerArrowTypeError a b = -- > server = getBooks -- > where getBooks :: Handler [Book] -- > getBooks = ...return all books... -#ifdef HAS_TYPE_ERROR instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context) -#else -instance (HasServer api context) -#endif => HasServer (Fragment a1 :> api) context where type ServerT (Fragment a1 :> api) m = ServerT api m @@ -905,3 +899,72 @@ instance (HasServer api context) -- $setup -- >>> import Servant + +-- | A type that specifies that an API record contains a server implementation. +data AsServerT (m :: * -> *) +instance GenericMode (AsServerT m) where + type AsServerT m :- api = ServerT api m + +type AsServer = AsServerT Handler + + +-- | Set of constraints required to convert to / from vanilla server types. +type GServerConstraints api m = + ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + , GServantProduct (Rep (api (AsServerT m))) + ) + +-- | This class is a necessary evil: in the implementation of 'HasServer' for +-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall +-- m. 'GServerConstraints' m@ to hold. +-- +-- We cannot require do that directly as the definition of 'GServerConstraints' +-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide +-- those type family applications behind a typeclass providing evidence for +-- @'GServerConstraints' api m@ in the form of a dictionary, and require that +-- @forall m. 'GServer' api m@ instead. +-- +-- Users shouldn't have to worry about this class, as the only possible instance +-- is provided in this module for all record APIs. + +class GServer (api :: * -> *) (m :: * -> *) where + proof :: Dict (GServerConstraints api m) + +instance + ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + , GServantProduct (Rep (api (AsServerT m))) + ) => GServer api m where + proof = Dict + +instance + ( HasServer (ToServantApi api) context + , forall m. Generic (api (AsServerT m)) + , forall m. GServer api m + ) => HasServer (NamedRoutes api) context where + + type ServerT (NamedRoutes api) m = api (AsServerT m) + + route + :: Proxy (NamedRoutes api) + -> Context context + -> Delayed env (api (AsServerT Handler)) + -> Router env + route _ ctx delayed = + case proof @api @Handler of + Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed) + + hoistServerWithContext + :: forall m n. Proxy (NamedRoutes api) + -> Proxy context + -> (forall x. m x -> n x) + -> api (AsServerT m) + -> api (AsServerT n) + hoistServerWithContext _ pctx nat server = + case (proof @api @m, proof @api @n) of + (Dict, Dict) -> + fromServant servantSrvN + where + servantSrvM :: ServerT (ToServantApi api) m = + toServant server + servantSrvN :: ServerT (ToServantApi api) n = + hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM diff --git a/servant/servant.cabal b/servant/servant.cabal index 41ea5792..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,6 +81,7 @@ library build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 + , constraints >= 0.2 , mtl >= 2.2.2 && < 2.3 , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6 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/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 50a7ee57..5a12e2e5 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links. @@ -125,6 +130,7 @@ module Servant.Links ( ) where import Data.List +import Data.Constraint import Data.Proxy (Proxy (..)) import Data.Singletons.Bool @@ -163,6 +169,8 @@ import Servant.API.IsSecure (IsSecure) import Servant.API.Modifiers (FoldRequired) +import Servant.API.NamedRoutes + (NamedRoutes) import Servant.API.QueryParam (QueryFlag, QueryParam', QueryParams) import Servant.API.Raw @@ -579,6 +587,34 @@ instance HasLink (Stream m status fr ct a) where instance HasLink (UVerb m ct a) where type MkLink (UVerb m ct a) r = r toLink toA _ = toA +-- Instance for NamedRoutes combinator + +type GLinkConstraints routes a = + ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a) + , GenericServant routes (AsLink a) + ) + +class GLink (routes :: * -> *) (a :: *) where + proof :: Dict (GLinkConstraints routes a) + +instance GLinkConstraints routes a => GLink routes a where + proof = Dict + +instance + ( HasLink (ToServantApi routes) + , forall a. GLink routes a + ) => HasLink (NamedRoutes routes) where + + type MkLink (NamedRoutes routes) a = routes (AsLink a) + + toLink + :: forall a. (Link -> a) + -> Proxy (NamedRoutes routes) + -> Link + -> routes (AsLink a) + + toLink toA _ l = case proof @routes @a of + Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where