diff --git a/cabal.project b/cabal.project index ccd9e5018..54136b810 100644 --- a/cabal.project +++ b/cabal.project @@ -10,7 +10,7 @@ packages: servant-client/ servant-docs/ servant-foreign/ - servant-http-streams/ + -- servant-http-streams/ servant-quickcheck/ servant-server/ servant-swagger/ diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index f3a53ad58..8763b13d4 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -64,7 +64,6 @@ import Servant.API NoContentVerb, ReflectMethod (..), StreamBody', - Verb, getResponse, AuthProtect, BasicAuth, BasicAuthData, Capture', CaptureAll, DeepQuery, Description, Fragment, FramingRender (..), FramingUnrender (..), Header', Headers (..), HttpVersion, MimeRender (mimeRender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, QueryString, Raw, RawM, RemoteHost, ReqBody', SBoolI, Stream, Summary, ToHttpApiData, ToSourceIO (..), Vault, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList, toEncodedUrlPiece, NamedRoutes) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi @@ -87,6 +86,7 @@ import Servant.Client.Core.ClientError import Servant.Client.Core.Request import Servant.Client.Core.Response import Servant.Client.Core.RunClient +import Servant.API.MultiVerb (MultiVerb) -- * Accessing APIs as a Client @@ -240,8 +240,8 @@ instance {-# OVERLAPPABLE #-} -- Note [Non-Empty Content Types] ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) , KnownNat status - ) => HasClient m (Verb method status cts' a) where - type Client m (Verb method status cts' a) = m a + ) => HasClient m (MultiVerb method status cts' a) where + type Client m (MultiVerb method status cts' a) = m a clientWithRoute _pm Proxy req = do response <- runRequestAcceptStatus (Just [status]) req { requestAccept = fromList $ toList accept @@ -257,8 +257,8 @@ instance {-# OVERLAPPABLE #-} instance {-# OVERLAPPING #-} ( RunClient m, ReflectMethod method, KnownNat status - ) => HasClient m (Verb method status cts NoContent) where - type Client m (Verb method status cts NoContent) + ) => HasClient m (MultiVerb method status cts NoContent) where + type Client m (MultiVerb method status cts NoContent) = m NoContent clientWithRoute _pm Proxy req = do _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method } @@ -283,8 +283,8 @@ instance {-# OVERLAPPING #-} -- Note [Non-Empty Content Types] ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status , ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' (Headers ls a)) where - type Client m (Verb method status cts' (Headers ls a)) + ) => HasClient m (MultiVerb method status cts' (Headers ls a)) where + type Client m (MultiVerb method status cts' (Headers ls a)) = m (Headers ls a) clientWithRoute _pm Proxy req = do response <- runRequestAcceptStatus (Just [status]) req @@ -304,8 +304,8 @@ instance {-# OVERLAPPING #-} instance {-# OVERLAPPING #-} ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status - ) => HasClient m (Verb method status cts (Headers ls NoContent)) where - type Client m (Verb method status cts (Headers ls NoContent)) + ) => HasClient m (MultiVerb method status cts (Headers ls NoContent)) where + type Client m (MultiVerb method status cts (Headers ls NoContent)) = m (Headers ls NoContent) clientWithRoute _pm Proxy req = do response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method } diff --git a/servant-client-core/src/Servant/Client/Core/Response.hs b/servant-client-core/src/Servant/Client/Core/Response.hs index 16ca0667a..bc5a415e8 100644 --- a/servant-client-core/src/Servant/Client/Core/Response.hs +++ b/servant-client-core/src/Servant/Client/Core/Response.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 1d6b57b19..cafdd1537 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -124,7 +124,7 @@ data OtherRoutes mode = OtherRoutes } deriving Generic -- Get for HTTP 307 Temporary Redirect -type Get307 = Verb 'GET 307 +type Get307 contentType returnType = Verb 'GET 307 contentType returnType data Filter = Filter { ageFilter :: Integer diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 965c626f2..edf4270dd 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveTraversable #-} module Servant.Server.Internal ( module Servant.Server.Internal @@ -32,6 +33,8 @@ import Data.Kind (Type) import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) +import Data.Sequence + (Seq) import Data.String (IsString (..)) import Data.Tagged @@ -56,7 +59,7 @@ import Servant.API Header', If, IsSecure (..), NoContentVerb, QueryFlag, QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, - Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, + Stream, StreamBody', Summary, ToSourceIO (..), Vault, WithNamedContext, WithResource, NamedRoutes) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant) import Servant.API.ContentTypes @@ -89,6 +92,8 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) +import Servant.API.MultiVerb (MultiVerb) +import Network.HTTP.Types (Header) class HasServer api context where -- | The type of a server for this API, given a monad to run effects in. @@ -315,9 +320,9 @@ noContentRouter method status action = leafRouter route' instance {-# OVERLAPPABLE #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - ) => HasServer (Verb method status ctypes a) context where + ) => HasServer (MultiVerb method status ctypes a) context where - type ServerT (Verb method status ctypes a) m = m a + type ServerT (MultiVerb method status ctypes a) m = m a hoistServerWithContext _ _ nt s = nt s route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status @@ -327,9 +332,9 @@ instance {-# OVERLAPPABLE #-} instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) - ) => HasServer (Verb method status ctypes (Headers h a)) context where + ) => HasServer (MultiVerb method status ctypes (Headers h a)) context where - type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) + type ServerT (MultiVerb method status ctypes (Headers h a)) m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status @@ -1114,3 +1119,9 @@ instance toServant server servantSrvN :: ServerT (ToServantApi api) n = hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM + +data InternalResponse a = InternalResponse + { statusCode :: Status + , headers :: Seq Header + , responseBody :: a + } deriving stock (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) diff --git a/servant/servant.cabal b/servant/servant.cabal index ef96a51e1..4ae3c0dbc 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -106,10 +106,12 @@ library Servant.API.Sub Servant.API.TypeErrors Servant.API.TypeLevel + Servant.API.TypeLevel.List Servant.API.UVerb Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs + Servant.API.MultiVerb Servant.API.WithNamedContext Servant.API.WithResource @@ -133,6 +135,7 @@ library , containers >=0.6 && <0.8 , mtl ^>=2.2.2 || ^>=2.3.1 , sop-core >=0.4.0.0 && <0.6 + , generics-sop ^>=0.5.1 , text >=1.2.3.0 && <2.2 , transformers >=0.5.2.0 && <0.7 diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index f6b0f4df4..bccb529e6 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -35,7 +35,6 @@ instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty - (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') instance Bifoldable (:<|>) where bifoldMap f g ~(a :<|> b) = f a `mappend` g b diff --git a/servant/src/Servant/API/MultiVerb.hs b/servant/src/Servant/API/MultiVerb.hs new file mode 100644 index 000000000..6efef6e9d --- /dev/null +++ b/servant/src/Servant/API/MultiVerb.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE EmptyCase #-} + +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Servant.API.MultiVerb + ( -- * MultiVerb types + MultiVerb, + MultiVerb1, + Respond, + RespondAs, + RespondEmpty, + RespondStreaming, + WithHeaders, + DescHeader, + OptHeader, + AsHeaders (..), + AsUnion (..), + eitherToUnion, + eitherFromUnion, + maybeToUnion, + maybeFromUnion, + AsConstructor (..), + GenericAsConstructor (..), + GenericAsUnion (..), + ResponseType, + ResponseTypes, + ) +where + +import Control.Applicative (Alternative(..), empty) +import qualified Data.CaseInsensitive as CI +import Data.Kind +import Data.Proxy +import Data.SOP +import Data.Sequence (Seq(..)) +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Generics.SOP as GSOP +import GHC.TypeLits +import Network.HTTP.Types as HTTP +import Data.ByteString (ByteString) +import Control.Monad (ap, MonadPlus(..)) + +import Servant.API.TypeLevel.List +import Servant.API.Stream (SourceIO) +import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) +import Servant.API.UVerb.Union (Union) +import Servant.API.Header (Header') + +-- | A type to describe a 'MultiVerb' response. +-- +-- Includes status code, description, and return type. The content type of the +-- response is determined dynamically using the accept header and the list of +-- supported content types specified in the containing 'MultiVerb' type. +data Respond (s :: Nat) (desc :: Symbol) (a :: Type) + +-- | A type to describe a 'MultiVerb' response with a fixed content type. +-- +-- Similar to 'Respond', but hardcodes the content type to be used for +-- generating the response. +data RespondAs ct (s :: Nat) (desc :: Symbol) (a :: Type) + +-- | A type to describe a 'MultiVerb' response with an empty body. +-- +-- Includes status code and description. +type RespondEmpty s desc = RespondAs '() s desc () + +-- | A type to describe a streaming 'MultiVerb' response. +-- +-- Includes status code, description, framing strategy and content type. Note +-- that the handler return type is hardcoded to be 'SourceIO ByteString'. +data RespondStreaming (s :: Nat) (desc :: Symbol) (framing :: Type) (ct :: Type) + +-- | The result of parsing a response as a union alternative of type 'a'. +-- +-- 'StatusMismatch' indicates that the response does not refer to the given +-- alternative, because the status code does not match the one produced by that +-- alternative. +-- +-- 'UnrenderError' and 'UnrenderSuccess' represent respectively a failing and +-- successful parse of the response body as a value of type 'a'. +-- +-- The 'UnrenderResult' type constructor has monad and alternative instances +-- corresponding to those of 'Either (Maybe (Last String)) a'. +data UnrenderResult a = StatusMismatch | UnrenderError String | UnrenderSuccess a + deriving (Eq, Show, Functor) + +instance Applicative UnrenderResult where + pure = UnrenderSuccess + (<*>) = ap + +instance Monad UnrenderResult where + return = pure + StatusMismatch >>= _ = StatusMismatch + UnrenderError e >>= _ = UnrenderError e + UnrenderSuccess x >>= f = f x + +instance Alternative UnrenderResult where + empty = mzero + (<|>) = mplus + +instance MonadPlus UnrenderResult where + mzero = StatusMismatch + mplus StatusMismatch m = m + mplus (UnrenderError e) StatusMismatch = UnrenderError e + mplus (UnrenderError _) m = m + mplus m@(UnrenderSuccess _) _ = m + +type family ResponseType a :: Type + +type instance ResponseType (Respond s desc a) = a + +type instance ResponseType (RespondAs ct s desc a) = a + +type instance ResponseType (RespondStreaming s desc framing ct) = SourceIO ByteString + +-- | This type adds response headers to a 'MultiVerb' response. +-- +-- Type variables: +-- * @hs@: type-level list of headers +-- * @a@: return type (with headers) +-- * @r@: underlying response (without headers) +data WithHeaders (hs :: [Type]) (a :: Type) (r :: Type) + +-- | This is used to convert a response containing headers to a custom type +-- including the information in the headers. +class AsHeaders xs a b where + fromHeaders :: (NP I xs, a) -> b + toHeaders :: b -> (NP I xs, a) + +-- single-header empty response +instance AsHeaders '[a] () a where + toHeaders a = (I a :* Nil, ()) + fromHeaders = unI . hd . fst + +-- single-header non-empty response, return value is a tuple of the response and the header +instance AsHeaders '[h] a (a, h) where + toHeaders (t, cc) = (I cc :* Nil, t) + fromHeaders (I cc :* Nil, t) = (t, cc) + +data DescHeader (name :: Symbol) (desc :: Symbol) (a :: Type) + +-- | A wrapper to turn a response header into an optional one. +data OptHeader h + +class ServantHeaders hs xs | hs -> xs where + constructHeaders :: NP I xs -> [HTTP.Header] + extractHeaders :: Seq HTTP.Header -> Maybe (NP I xs) + +instance ServantHeaders '[] '[] where + constructHeaders Nil = [] + extractHeaders _ = Just Nil + +headerName :: forall name. (KnownSymbol name) => HTTP.HeaderName +headerName = + CI.mk + . Text.encodeUtf8 + . Text.pack + $ symbolVal (Proxy @name) + +instance + ( KnownSymbol name, + ServantHeader h name x, + FromHttpApiData x, + ServantHeaders hs xs + ) => + ServantHeaders (h ': hs) (x ': xs) + where + constructHeaders (I x :* xs) = + constructHeader @h x + <> constructHeaders @hs xs + + -- FUTUREWORK: should we concatenate all the matching headers instead of just + -- taking the first one? + extractHeaders hs = do + let name' = headerName @name + (hs0, hs1) = Seq.partition (\(h, _) -> h == name') hs + x <- case hs0 of + Seq.Empty -> empty + ((_, h) :<| _) -> either (const empty) pure (parseHeader h) + xs <- extractHeaders @hs hs1 + pure (I x :* xs) + +class ServantHeader h (name :: Symbol) x | h -> name x where + constructHeader :: x -> [HTTP.Header] + +instance + (KnownSymbol name, ToHttpApiData x) => + ServantHeader (Header' mods name x) name x + where + constructHeader x = [(headerName @name, toHeader x)] + +instance + (KnownSymbol name, ToHttpApiData x) => + ServantHeader (DescHeader name desc x) name x + where + constructHeader x = [(headerName @name, toHeader x)] + +instance (ServantHeader h name x) => ServantHeader (OptHeader h) name (Maybe x) where + constructHeader = foldMap (constructHeader @h) + +type instance ResponseType (WithHeaders hs a r) = a + +type family ResponseTypes (as :: [Type]) where + ResponseTypes '[] = '[] + ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as + +-- | This type can be used in Servant to produce an endpoint which can return +-- multiple values with various content types and status codes. It is similar to +-- 'UVerb' and behaves similarly, but it has some important differences: +-- +-- * Descriptions and statuses can be attached to individual responses without +-- using wrapper types and without affecting the handler return type. +-- * The return type of the handler can be decoupled from the types of the +-- individual responses. One can use a 'Union' type just like for 'UVerb', +-- but 'MultiVerb' also supports using an arbitrary type with an 'AsUnion' +-- instance. +-- * Headers can be attached to individual responses, also without affecting +-- the handler return type. +data MultiVerb (method :: StdMethod) cs (as :: [Type]) (r :: Type) + +-- | A 'MultiVerb' endpoint with a single response. +type MultiVerb1 m cs a = MultiVerb m cs '[a] (ResponseType a) + + +-- | This class is used to convert a handler return type to a union type +-- including all possible responses of a 'MultiVerb' endpoint. +-- +-- Any glue code necessary to convert application types to and from the +-- canonical 'Union' type corresponding to a 'MultiVerb' endpoint should be +-- packaged into an 'AsUnion' instance. +class AsUnion (as :: [Type]) (r :: Type) where + toUnion :: r -> Union (ResponseTypes as) + fromUnion :: Union (ResponseTypes as) -> r + +-- | Unions can be used directly as handler return types using this trivial +-- instance. +instance (rs ~ ResponseTypes as) => AsUnion as (Union rs) where + toUnion = id + fromUnion = id + +-- | A handler with a single response. +instance (ResponseType r ~ a) => AsUnion '[r] a where + toUnion = Z . I + fromUnion = unI . unZ + +_foo :: Union '[Int] +_foo = toUnion @'[Respond 200 "test" Int] @Int 3 + +class InjectAfter as bs where + injectAfter :: Union bs -> Union (as .++ bs) + +instance InjectAfter '[] bs where + injectAfter = id + +instance (InjectAfter as bs) => InjectAfter (a ': as) bs where + injectAfter = S . injectAfter @as @bs + +class InjectBefore as bs where + injectBefore :: Union as -> Union (as .++ bs) + +instance InjectBefore '[] bs where + injectBefore x = case x of {} + +instance (InjectBefore as bs) => InjectBefore (a ': as) bs where + injectBefore (Z x) = Z x + injectBefore (S x) = S (injectBefore @as @bs x) + +eitherToUnion :: + forall as bs a b. + (InjectAfter as bs, InjectBefore as bs) => + (a -> Union as) -> + (b -> Union bs) -> + (Either a b -> Union (as .++ bs)) +eitherToUnion f _ (Left a) = injectBefore @as @bs (f a) +eitherToUnion _ g (Right b) = injectAfter @as @bs (g b) + +class EitherFromUnion as bs where + eitherFromUnion :: + (Union as -> a) -> + (Union bs -> b) -> + (Union (as .++ bs) -> Either a b) + +instance EitherFromUnion '[] bs where + eitherFromUnion _ g = Right . g + +instance (EitherFromUnion as bs) => EitherFromUnion (a ': as) bs where + eitherFromUnion f _ (Z x) = Left (f (Z x)) + eitherFromUnion f g (S x) = eitherFromUnion @as @bs (f . S) g x + +maybeToUnion :: + forall as a. + (InjectAfter as '[()], InjectBefore as '[()]) => + (a -> Union as) -> + (Maybe a -> Union (as .++ '[()])) +maybeToUnion f (Just a) = injectBefore @as @'[()] (f a) +maybeToUnion _ Nothing = injectAfter @as @'[()] (Z (I ())) + +maybeFromUnion :: + forall as a. + (EitherFromUnion as '[()]) => + (Union as -> a) -> + (Union (as .++ '[()]) -> Maybe a) +maybeFromUnion f = leftToMaybe . eitherFromUnion @as @'[()] f (const (Z (I ()))) + where + leftToMaybe = either Just (const Nothing) + +-- | This class can be instantiated to get automatic derivation of 'AsUnion' +-- instances via 'GenericAsUnion'. The idea is that one has to make sure that for +-- each response @r@ in a 'MultiVerb' endpoint, there is an instance of +-- @AsConstructor xs r@ for some @xs@, and that the list @xss@ of all the +-- corresponding @xs@ is equal to 'GSOP.Code' of the handler type. Then one can +-- write: +-- @ +-- type Responses = ... +-- data Result = ... +-- deriving stock (Generic) +-- deriving (AsUnion Responses) via (GenericAsUnion Responses Result) +-- +-- instance GSOP.Generic Result +-- @ +-- and get an 'AsUnion' instance for free. +-- +-- There are a few predefined instances for constructors taking a single type +-- corresponding to a simple response, and for empty responses, but in more +-- general cases one either has to define an 'AsConstructor' instance by hand, +-- or derive it via 'GenericAsConstructor'. +class AsConstructor xs r where + toConstructor :: ResponseType r -> NP I xs + fromConstructor :: NP I xs -> ResponseType r + +class AsConstructors xss rs where + toSOP :: Union (ResponseTypes rs) -> SOP I xss + fromSOP :: SOP I xss -> Union (ResponseTypes rs) + +instance AsConstructors '[] '[] where + toSOP x = case x of {} + fromSOP x = case x of {} + +instance AsConstructor '[a] (Respond code desc a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + +instance AsConstructor '[a] (RespondAs (ct :: Type) code desc a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + +instance AsConstructor '[] (RespondEmpty code desc) where + toConstructor _ = Nil + fromConstructor _ = () + +newtype GenericAsConstructor r = GenericAsConstructor r + +type instance ResponseType (GenericAsConstructor r) = ResponseType r + +instance + (GSOP.Code (ResponseType r) ~ '[xs], GSOP.Generic (ResponseType r)) => + AsConstructor xs (GenericAsConstructor r) + where + toConstructor = unZ . unSOP . GSOP.from + fromConstructor = GSOP.to . SOP . Z + +instance + (AsConstructor xs r, AsConstructors xss rs) => + AsConstructors (xs ': xss) (r ': rs) + where + toSOP (Z (I x)) = SOP . Z $ toConstructor @xs @r x + toSOP (S x) = SOP . S . unSOP $ toSOP @xss @rs x + + fromSOP (SOP (Z x)) = Z (I (fromConstructor @xs @r x)) + fromSOP (SOP (S x)) = S (fromSOP @xss @rs (SOP x)) + +-- | This type is meant to be used with @deriving via@ in order to automatically +-- generate an 'AsUnion' instance using 'Generics.SOP'. +-- +-- See 'AsConstructor' for more information and examples. +newtype GenericAsUnion rs a = GenericAsUnion a + +instance + (GSOP.Code a ~ xss, GSOP.Generic a, AsConstructors xss rs) => + AsUnion rs (GenericAsUnion rs a) + where + toUnion (GenericAsUnion x) = fromSOP @xss @rs (GSOP.from x) + fromUnion = GenericAsUnion . GSOP.to . toSOP @xss @rs + +-- | A handler for a pair of empty responses can be implemented simply by +-- returning a boolean value. The convention is that the "failure" case, normally +-- represented by 'False', corresponds to the /first/ response. +instance + AsUnion + '[ RespondEmpty s1 desc1, + RespondEmpty s2 desc2 + ] + Bool + where + toUnion False = Z (I ()) + toUnion True = S (Z (I ())) + + fromUnion (Z (I ())) = False + fromUnion (S (Z (I ()))) = True + fromUnion (S (S x)) = case x of {} + +-- | A handler for a pair of responses where the first is empty can be +-- implemented simply by returning a 'Maybe' value. The convention is that the +-- "failure" case, normally represented by 'Nothing', corresponds to the /first/ +-- response. +instance + (ResponseType r1 ~ (), ResponseType r2 ~ a) => + AsUnion '[r1, r2] (Maybe a) + where + toUnion Nothing = Z (I ()) + toUnion (Just x) = S (Z (I x)) + + fromUnion (Z (I ())) = Nothing + fromUnion (S (Z (I x))) = Just x + fromUnion (S (S x)) = case x of {} diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 9e2f91119..42ee42bd1 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -47,7 +47,7 @@ module Servant.API.TypeLevel ( And, -- ** Fragment FragmentUnique, - AtMostOneFragment + AtMostOneFragment, ) where @@ -72,12 +72,11 @@ import Servant.API.Generic (ToServantApi) import Servant.API.Sub (type (:>)) -import Servant.API.Verbs - (Verb) import Servant.API.UVerb (UVerb) import GHC.TypeLits (ErrorMessage (..), TypeError) +import Servant.API.MultiVerb @@ -146,7 +145,7 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb IsElem sa (Fragment x :> sb) = IsElem sa sb - IsElem (Verb m s ct typ) (Verb m s ct' typ) + IsElem (MultiVerb m s ct typ) (MultiVerb m s ct' typ) = IsSubList ct ct' IsElem e e = () IsElem e (NamedRoutes rs) = IsElem e (ToServantApi rs) @@ -273,7 +272,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -- ... class FragmentUnique api => AtMostOneFragment api -instance AtMostOneFragment (Verb m s ct typ) +instance AtMostOneFragment (MultiVerb m s ct typ) instance AtMostOneFragment (UVerb m cts as) diff --git a/servant/src/Servant/API/TypeLevel/List.hs b/servant/src/Servant/API/TypeLevel/List.hs new file mode 100644 index 000000000..dd42a5b65 --- /dev/null +++ b/servant/src/Servant/API/TypeLevel/List.hs @@ -0,0 +1,9 @@ +module Servant.API.TypeLevel.List + (type (.++) + ) where + +import Data.Kind + +type family (.++) (l1 :: [Type]) (l2 :: [Type]) where + '[] .++ a = a + (a ': as) .++ b = a ': (as .++ b) diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index fbe77e656..29b3aba9d 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -22,14 +22,16 @@ import Network.HTTP.Types.Method (Method, StdMethod (..), methodConnect, methodDelete, methodGet, methodHead, methodOptions, methodPatch, methodPost, methodPut, methodTrace) +import Servant.API.MultiVerb (MultiVerb1, Respond) -- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For -- convenience, type synonyms for each verb with a 200 response code are -- provided, but you are free to define your own: -- -- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a -data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type) - deriving (Typeable, Generic) +-- data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type) +type Verb (method :: StdMethod) (statusCode :: Nat) (contentTypes :: [Type]) (returnType :: Type) + = MultiVerb1 method contentTypes (Respond statusCode "" returnType) -- | @NoContentVerb@ is a specific type to represent 'NoContent' responses. -- It does not require either a list of content types (because there's @@ -47,15 +49,15 @@ data NoContentVerb (method :: k1) -- the relevant information is summarily presented here. -- | 'GET' with 200 status code. -type Get = Verb 'GET 200 +type Get contentTypes returnType = Verb 'GET 200 contentTypes returnType -- | 'POST' with 200 status code. -type Post = Verb 'POST 200 +type Post contentTypes returnType = Verb 'POST 200 contentTypes returnType -- | 'PUT' with 200 status code. -type Put = Verb 'PUT 200 +type Put contentTypes returnType = Verb 'PUT 200 contentTypes returnType -- | 'DELETE' with 200 status code. -type Delete = Verb 'DELETE 200 +type Delete contentTypes returnType = Verb 'DELETE 200 contentTypes returnType -- | 'PATCH' with 200 status code. -type Patch = Verb 'PATCH 200 +type Patch contentTypes returnType = Verb 'PATCH 200 contentTypes returnType -- * Other responses @@ -72,9 +74,9 @@ type Patch = Verb 'PATCH 200 -- field. -- | 'POST' with 201 status code. -type PostCreated = Verb 'POST 201 +type PostCreated contentTypes returnType = Verb 'POST 201 contentTypes returnType -- | 'PUT' with 201 status code. -type PutCreated = Verb 'PUT 201 +type PutCreated contentTypes returnType = Verb 'PUT 201 contentTypes returnType -- ** 202 Accepted @@ -85,15 +87,15 @@ type PutCreated = Verb 'PUT 201 -- estimate of when the processing will be finished. -- | 'GET' with 202 status code. -type GetAccepted = Verb 'GET 202 +type GetAccepted contentTypes returnType = Verb 'GET 202 contentTypes returnType -- | 'POST' with 202 status code. -type PostAccepted = Verb 'POST 202 +type PostAccepted contentTypes returnType = Verb 'POST 202 contentTypes returnType -- | 'DELETE' with 202 status code. -type DeleteAccepted = Verb 'DELETE 202 +type DeleteAccepted contentTypes returnType = Verb 'DELETE 202 contentTypes returnType -- | 'PATCH' with 202 status code. -type PatchAccepted = Verb 'PATCH 202 +type PatchAccepted contentTypes returnType = Verb 'PATCH 202 contentTypes returnType -- | 'PUT' with 202 status code. -type PutAccepted = Verb 'PUT 202 +type PutAccepted contentTypes returnType = Verb 'PUT 202 contentTypes returnType -- ** 203 Non-Authoritative Information @@ -102,15 +104,15 @@ type PutAccepted = Verb 'PUT 202 -- information may come from a third-party. -- | 'GET' with 203 status code. -type GetNonAuthoritative = Verb 'GET 203 +type GetNonAuthoritative contentTypes returnType = Verb 'GET 203 contentTypes returnType -- | 'POST' with 203 status code. -type PostNonAuthoritative = Verb 'POST 203 +type PostNonAuthoritative contentTypes returnType = Verb 'POST 203 contentTypes returnType -- | 'DELETE' with 203 status code. -type DeleteNonAuthoritative = Verb 'DELETE 203 +type DeleteNonAuthoritative contentTypes returnType = Verb 'DELETE 203 contentTypes returnType -- | 'PATCH' with 203 status code. -type PatchNonAuthoritative = Verb 'PATCH 203 +type PatchNonAuthoritative contentTypes returnType = Verb 'PATCH 203 contentTypes returnType -- | 'PUT' with 203 status code. -type PutNonAuthoritative = Verb 'PUT 203 +type PutNonAuthoritative contentTypes returnType = Verb 'PUT 203 contentTypes returnType -- ** 204 No Content @@ -141,15 +143,15 @@ type HeadNoContent = NoContentVerb 'HEAD -- If the document view should not be reset, use @204 No Content@. -- | 'GET' with 205 status code. -type GetResetContent = Verb 'GET 205 +type GetResetContent contentTypes returnType = Verb 'GET 205 contentTypes returnType -- | 'POST' with 205 status code. -type PostResetContent = Verb 'POST 205 +type PostResetContent contentTypes returnType = Verb 'POST 205 contentTypes returnType -- | 'DELETE' with 205 status code. -type DeleteResetContent = Verb 'DELETE 205 +type DeleteResetContent contentTypes returnType = Verb 'DELETE 205 contentTypes returnType -- | 'PATCH' with 205 status code. -type PatchResetContent = Verb 'PATCH 205 +type PatchResetContent contentTypes returnType = Verb 'PATCH 205 contentTypes returnType -- | 'PUT' with 205 status code. -type PutResetContent = Verb 'PUT 205 +type PutResetContent contentTypes returnType = Verb 'PUT 205 contentTypes returnType -- ** 206 Partial Content @@ -161,7 +163,7 @@ type PutResetContent = Verb 'PUT 205 -- RFC7233 Section 4.1> -- | 'GET' with 206 status code. -type GetPartialContent = Verb 'GET 206 +type GetPartialContent contentTypes returnType = Verb 'GET 206 contentTypes returnType class ReflectMethod a where diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 82c285d9d..7a2536594 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -177,12 +177,13 @@ import Servant.API.UVerb import Servant.API.Vault (Vault) import Servant.API.Verbs - (Verb, NoContentVerb) + (NoContentVerb) import Servant.API.WithNamedContext (WithNamedContext) import Servant.API.WithResource (WithResource) import Web.HttpApiData +import Servant.API.MultiVerb (MultiVerb) -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any @@ -564,8 +565,8 @@ instance HasLink EmptyAPI where toLink _ _ _ = EmptyAPI -- Verb (terminal) instances -instance HasLink (Verb m s ct a) where - type MkLink (Verb m s ct a) r = r +instance HasLink (MultiVerb m s ct a) where + type MkLink (MultiVerb m s ct a) r = r toLink toA _ = toA instance HasLink (NoContentVerb m) where @@ -646,7 +647,6 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub) -- $setup -- >>> import Servant.API -- >>> import Data.Text (Text) - -- Erroring instance for 'HasLink' when a combinator is not fully applied instance TypeError (PartialApplication #if __GLASGOW_HASKELL__ >= 904