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