From 33568db4de03cb5dc82ae51379d27d5b2fd1800a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Fri, 12 Dec 2025 09:29:16 +0100 Subject: [PATCH 1/5] Add MultiVerb-specific test for duplicate header extraction (SetCookie) Add test case that directly exercises MultiVerb's extractHeaders function with duplicate header names (Set-Cookie headers). This validates the fix in commit c2cc84f9 which changed extractHeaders to use findIndexL + deleteAt instead of Seq.partition, allowing multiple headers with the same name to be correctly parsed. The test uses WithHeaders with two Set-Cookie headers and verifies both cookies are properly extracted on the client side. --- .../test/Servant/ClientTestUtils.hs | 19 +++++++++++++++++++ servant-client/test/Servant/SuccessSpec.hs | 9 +++++++++ 2 files changed, 28 insertions(+) diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 2af8bbc9e..d0d51d61e 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -138,6 +138,21 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type TestSetCookieHeaders = '[Header "Set-Cookie" String, Header "Set-Cookie" String] +-- | AsHeaders instance for extracting two Set-Cookie headers +-- Returns: (body, (cookie1, cookie2)) +instance AsHeaders '[a, b] c (c, (a, b)) where + toHeaders (body, (h1, h2)) = (I h1 :* I h2 :* Nil, body) + fromHeaders (I h1 :* I h2 :* Nil, body) = (body, (h1, h2)) + +-- | MultiVerb endpoint definition for SetCookie test +type MultiVerbSetCookie = + "multiverb-set-cookie" + :> MultiVerb + 'GET + '[JSON] + '[WithHeaders TestSetCookieHeaders (Bool, (String, String)) (Respond 200 "OK" Bool)] + (Bool, (String, String)) + data RecordRoutes mode = RecordRoutes { version :: mode :- "version" :> Get '[JSON] Int , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String @@ -252,6 +267,7 @@ type Api = :<|> "multiple-choices-int" :> MultipleChoicesInt :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text :<|> "host-test" :> Host "servant.example" :> Get '[JSON] Bool + :<|> MultiVerbSetCookie :<|> PaginatedAPI api :: Proxy Api @@ -298,6 +314,7 @@ recordRoutes :: RecordRoutes (AsClientT ClientM) multiChoicesInt :: Int -> ClientM MultipleChoicesIntResult captureVerbatim :: Verbatim -> ClientM Text getHost :: ClientM Bool +getMultiVerbSetCookie :: ClientM (Bool, (String, String)) getPaginatedPerson :: Maybe (Range 1 100) -> ClientM [Person] getRoot :<|> getGet @@ -329,6 +346,7 @@ getRoot :<|> multiChoicesInt :<|> captureVerbatim :<|> getHost + :<|> getMultiVerbSetCookie :<|> getPaginatedPerson = client api server :: Application @@ -409,6 +427,7 @@ server = ) :<|> pure . decodeUtf8 . unVerbatim :<|> pure True + :<|> pure (True, ("cookie1", "cookie2")) :<|> usersServer ) diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index 435f97a05..f16420334 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -147,6 +147,15 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("Set-Cookie", "cookie1"), ("Set-Cookie", "cookie2")] + it "Returns multiple Set-Cookie headers via MultiVerb WithHeaders" $ \(_, baseUrl) -> do + res <- runClient getMultiVerbSetCookie baseUrl + case res of + Left e -> assertFailure $ show e + Right (body, (cookie1, cookie2)) -> do + body `shouldBe` True + cookie1 `shouldBe` "cookie1" + cookie2 `shouldBe` "cookie2" + it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings cj <- atomically . newTVar $ C.createCookieJar [] From e5610be22b8950a0443e1e3154bf5344f39dcac4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 11 Dec 2025 17:02:23 +0100 Subject: [PATCH 2/5] Fix extractHeaders to handle duplicate header names The previous implementation used Seq.partition to remove ALL headers with the matching name at once. This commit changes its behavior to accept duplicate header names (particularly important for some special headers such as `Set-Cookie`). --- servant-client/test/Servant/ClientTestUtils.hs | 2 +- servant/src/Servant/API/MultiVerb.hs | 14 ++++++++------ 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index d0d51d61e..b6cefc462 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -138,7 +138,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type TestSetCookieHeaders = '[Header "Set-Cookie" String, Header "Set-Cookie" String] --- | AsHeaders instance for extracting two Set-Cookie headers +-- | AsHeaders instance for extracting two headers (Required by the MultiVerbSetCookie test) -- Returns: (body, (cookie1, cookie2)) instance AsHeaders '[a, b] c (c, (a, b)) where toHeaders (body, (h1, h2)) = (I h1 :* I h2 :* Nil, body) diff --git a/servant/src/Servant/API/MultiVerb.hs b/servant/src/Servant/API/MultiVerb.hs index 45ea5a816..f885abe52 100644 --- a/servant/src/Servant/API/MultiVerb.hs +++ b/servant/src/Servant/API/MultiVerb.hs @@ -187,14 +187,16 @@ instance constructHeader @h x <> constructHeaders @headers xs - -- NOTE: should we concatenate all the matching headers instead of just taking the first one? + -- This implementation retrieves the *first* header with matching name. + -- It leaves other instances of the same header intact for subsequent extraction, which allows + -- multiple headers with the same name to be extracted (e.g. Set-Cookie). extractHeaders headers = do let name' = headerName @name - (headers0, headers1) = Seq.partition (\(h, _) -> h == name') headers - x <- case headers0 of - Seq.Empty -> empty - ((_, h) :<| _) -> either (const empty) pure (parseHeader h) - xs <- extractHeaders @headers headers1 + idx <- Seq.findIndexL (\(h, _) -> h == name') headers + let (_, val) = Seq.index headers idx + headers' = Seq.deleteAt idx headers + x <- either (const empty) pure (parseHeader val) + xs <- extractHeaders @headers headers' pure (I x :* xs) class ServantHeader h (name :: Symbol) x | h -> name x where From 920668959115b2bef44e43a4cd7ea57b94555061 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 11 Dec 2025 15:29:45 +0100 Subject: [PATCH 3/5] Make Verb and NoContentVerb HasServer instances delegate to MultiVerb This is the first step toward unifying endpoint types around MultiVerb. Changes: - Verb's HasServer instances now delegate to MultiVerb - NoContentVerb delegates to MultiVerb with RespondAs '() 204 - Verb and NoContentVerb method parameter changed from polymorphic (k1) to strict (StdMethod) for consistency with MultiVerb. This is a breaking change, but arguably not a major one: I doubt that this extra polymorphism was ever used. - Added KnownStatus constraint to Verb instances. We previously only required `KnownNat`, but we need `KnownStatus` to be able to express `Verb` in terms of `MultiVerb. This is another potential breaking change: users using non-standard, custom statuses will have to implement `KnownStatus` instances. - Added ResponseRender instance for Respond with Headers to support the delegation Removed dead code: - methodRouter (was only used by Verb) - noContentRouter (was only used by NoContentVerb) - responseLBS import (no longer needed) Test changes: - Added KnownStatus instances for non-standard test status codes (210, 214, 280) --- .../QuickCheck/Internal/HasGenRequest.hs | 5 +- servant-server/src/Servant/Server/Internal.hs | 72 ++++--------------- .../Servant/Server/Internal/ResponseRender.hs | 25 +++++++ servant-server/test/Servant/ServerSpec.hs | 7 ++ .../src/Servant/Swagger/Internal.hs | 2 +- servant/src/Servant/API/Status.hs | 10 ++- servant/src/Servant/API/Verbs.hs | 4 +- 7 files changed, 56 insertions(+), 69 deletions(-) diff --git a/servant-quickcheck/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/servant-quickcheck/src/Servant/QuickCheck/Internal/HasGenRequest.hs index cd447384d..50810834f 100644 --- a/servant-quickcheck/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/servant-quickcheck/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StarIsType #-} module Servant.QuickCheck.Internal.HasGenRequest where @@ -223,7 +222,7 @@ instance instance ReflectMethod method - => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [Type]) a) + => HasGenRequest (Verb (method :: StdMethod) (status :: Nat) (cts :: [Type]) a) where genRequest _ = ( 1 @@ -238,7 +237,7 @@ instance instance ReflectMethod method - => HasGenRequest (NoContentVerb (method :: k)) + => HasGenRequest (NoContentVerb (method :: StdMethod)) where genRequest _ = ( 1 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 081b73c5d..2c09dafa1 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -16,7 +16,7 @@ module Servant.Server.Internal where import Control.Applicative ((<|>)) -import Control.Monad (join, unless, when) +import Control.Monad (join, unless, void, when) import Control.Monad.Trans (lift, liftIO) import Control.Monad.Trans.Resource (ReleaseKey, runResourceT) import Data.Acquire @@ -60,7 +60,6 @@ import Network.Wai , requestHeaderHost , requestHeaders , requestMethod - , responseLBS , responseStream , vault ) @@ -111,6 +110,7 @@ import Servant.API.ContentTypes , AllCTRender (..) , AllCTUnrender (..) , AllMime + , AllMimeRender , MimeRender (..) , MimeUnrender (..) , NoContent @@ -138,7 +138,7 @@ import Servant.API.ResponseHeaders , getHeaders , getResponse ) -import Servant.API.Status (statusFromNat) +import Servant.API.Status (KnownStatus, statusFromNat) import Servant.API.TypeErrors import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) import qualified Servant.Types.SourceT as S @@ -369,54 +369,11 @@ acceptCheck proxy accH | canHandleAcceptH proxy accH = pure () | otherwise = delayedFail err406 -methodRouter - :: AllCTRender ctypes a - => (b -> ([(HeaderName, B.ByteString)], a)) - -> Method - -> Proxy ctypes - -> Status - -> Delayed env (Handler b) - -> Router env -methodRouter splitHeaders method proxy status action = leafRouter route' - where - route' env request respond = - let accH = getAcceptHeader request - in runAction - ( action - `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH - ) - env - request - respond - $ \output -> do - let (headers, b) = splitHeaders output - case handleAcceptH proxy accH b of - Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does - Just (contentT, body) -> - let bdy = if allowedMethodHead method request then "" else body - in Route $ responseLBS status ((hContentType, BSL.toStrict contentT) : headers) bdy - -noContentRouter - :: Method - -> Status - -> Delayed env (Handler b) - -> Router env -noContentRouter method status action = leafRouter route' - where - route' env request respond = - runAction - (action `addMethodCheck` methodCheck method request) - env - request - respond - $ \_output -> - Route $ responseLBS status [] "" - instance {-# OVERLAPPABLE #-} ( AllCTRender ctypes a - , KnownNat status + , AllMimeRender ctypes a + , KnownStatus status , ReflectMethod method ) => HasServer (Verb method status ctypes a) context @@ -424,16 +381,14 @@ instance type ServerT (Verb method status ctypes a) m = m a hoistServerWithContext _ _ nt = nt - route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status - where - method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) + route Proxy = route (Proxy @(MultiVerb method ctypes '[Respond status "" a] a)) instance {-# OVERLAPPING #-} ( AllCTRender ctypes a + , AllMimeRender ctypes a , GetHeaders (Headers h a) - , KnownNat status + , KnownStatus status , ReflectMethod method ) => HasServer (Verb method status ctypes (Headers h a)) context @@ -441,10 +396,7 @@ instance type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) hoistServerWithContext _ _ nt = nt - route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status - where - method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) + route Proxy = route (Proxy @(MultiVerb method ctypes '[Respond status "" (Headers h a)] (Headers h a))) instance ReflectMethod method @@ -453,9 +405,9 @@ instance type ServerT (NoContentVerb method) m = m NoContent hoistServerWithContext _ _ nt = nt - route Proxy _ = noContentRouter method status204 - where - method = reflectMethod (Proxy :: Proxy method) + route Proxy ctx action = + route (Proxy @(MultiVerb method '() '[RespondAs '() 204 "" ()] ())) ctx $ + fmap void action instance {-# OVERLAPPABLE #-} diff --git a/servant-server/src/Servant/Server/Internal/ResponseRender.hs b/servant-server/src/Servant/Server/Internal/ResponseRender.hs index 962364f70..d76883fc7 100644 --- a/servant-server/src/Servant/Server/Internal/ResponseRender.hs +++ b/servant-server/src/Servant/Server/Internal/ResponseRender.hs @@ -25,6 +25,7 @@ import Servant.API.ContentTypes , mimeRender ) import Servant.API.MultiVerb +import Servant.API.ResponseHeaders (GetHeaders (..), Headers, getResponse) import Servant.API.Status import Servant.API.Stream (SourceIO) import Servant.API.UVerb.Union @@ -154,6 +155,7 @@ instance } instance + {-# OVERLAPPABLE #-} (AllMimeRender cs a, KnownStatus s) => ResponseRender cs (Respond s desc a) where @@ -176,6 +178,29 @@ instance , headers = mempty } +-- | Instance for Respond with Headers - extracts headers from the Headers wrapper +-- This enables Verb with Headers to delegate to MultiVerb +instance + {-# OVERLAPPING #-} + (AllMimeRender cs a, GetHeaders (Headers h a), KnownStatus s) + => ResponseRender cs (Respond s desc (Headers h a)) + where + type ResponseStatus (Respond s desc (Headers h a)) = s + type ResponseBody (Respond s desc (Headers h a)) = BSL.ByteString + + responseRender (AcceptHeader acc) headersVal = + M.mapAcceptMedia (map (uncurry mkRenderOutput) (allMimeRender (Proxy @cs) (getResponse headersVal))) acc + where + responseHeaders = Seq.fromList (getHeaders headersVal) + mkRenderOutput :: M.MediaType -> BSL.ByteString -> (M.MediaType, InternalResponse BSL.ByteString) + mkRenderOutput c body = + (c,) . addContentType' c $ + InternalResponse + { statusCode = statusVal (Proxy @s) + , responseBody = body + , headers = responseHeaders + } + addContentType :: forall ct a. Accept ct => InternalResponse a -> InternalResponse a addContentType = addContentType' (contentType (Proxy @ct)) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index f3b36bcdc..a9798fc31 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -115,6 +115,7 @@ import Servant.API , (:>) ) import Servant.API.QueryString (FromDeepQuery (..)) +import Servant.API.Status (KnownStatus (..), statusFromNat) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) @@ -156,6 +157,12 @@ import Servant.Server.Internal.BasicAuth ) import Servant.Server.Internal.Context (NamedContext (..)) +-- * KnownStatus instances for non-standard test status codes + +instance KnownStatus 210 where statusVal _ = statusFromNat (Proxy @210) +instance KnownStatus 214 where statusVal _ = statusFromNat (Proxy @214) +instance KnownStatus 280 where statusVal _ = statusFromNat (Proxy @280) + -- * comprehensive api test -- This declaration simply checks that all instances are in place. diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs index c3aa5253c..67d6c42dd 100644 --- a/servant-swagger/src/Servant/Swagger/Internal.hs +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -285,7 +285,7 @@ instance {-# OVERLAPPABLE #-} (AllAccept cs, KnownNat status, SwaggerMethod meth toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a))) -- | @since 1.1.7 -instance (Accept ct, KnownNat status, SwaggerMethod method, ToSchema a) => HasSwagger (Stream method status fr ct a) where +instance (Accept ct, KnownNat status, SwaggerMethod method, ToSchema a) => HasSwagger (Stream (method :: StdMethod) status fr ct a) where toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a))) instance diff --git a/servant/src/Servant/API/Status.hs b/servant/src/Servant/API/Status.hs index 95268d3ea..4468a74d7 100644 --- a/servant/src/Servant/API/Status.hs +++ b/servant/src/Servant/API/Status.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-} --- Flexible instances is necessary on GHC 8.4 and earlier -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Servant.API.Status where @@ -12,7 +10,13 @@ import Network.HTTP.Types.Status statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status statusFromNat = toEnum . fromInteger . natVal --- | Witness that a type-level natural number corresponds to a HTTP status code +-- | Witness that a type-level natural number corresponds to a HTTP status code. +-- +-- Provides instances for all standard HTTP status codes. For non-standard codes, +-- you can define your own instance: +-- +-- > instance KnownStatus 299 where +-- > statusVal _ = statusFromNat (Proxy @299) class KnownNat n => KnownStatus n where statusVal :: proxy n -> Status diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 3c3e68244..3d7a2d350 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -33,13 +33,13 @@ import Network.HTTP.Types.Method -- 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) +data Verb (method :: StdMethod) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type) deriving (Generic, Typeable) -- | @NoContentVerb@ is a specific type to represent 'NoContent' responses. -- It does not require either a list of content types (because there's -- no content) or a status code (because it should always be 204). -data NoContentVerb (method :: k1) +data NoContentVerb (method :: StdMethod) deriving (Generic, Typeable) -- * 200 responses From 37b543a0bb266feee4c4f7c30ccec4f64be394bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 11 Dec 2025 17:08:32 +0100 Subject: [PATCH 4/5] Unify Verb/NoContentVerb HasClient instances via MultiVerb delegation HasClient instances become thin wrappers around the MultiVerb one. Introduced a NPToHList class as a compatiblity layer between Verb / MultiVerb for header handling. Breaking change: Response header handling is now stricter in clients, matching MultiVerb behavior. Before: Missing/malformed headers returned MissingHeader/UndecodableHeader constructors - callers could inspect and handle gracefully. After: Missing/malformed headers fail the request immediately with "Failed to parse headers". In a way, this enforces the API contract: if a header is declared in the type, it must be present and valid. Use Optional headers if truly optional. --- .../src/Servant/Client/Core/HasClient.hs | 166 +++++------------- servant/src/Servant/API/MultiVerb.hs | 28 +++ 2 files changed, 76 insertions(+), 118 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 96f48a33f..d840f3712 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -35,7 +35,7 @@ import qualified Data.Text as T import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import Data.Typeable -import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, symbolVal) +import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) import Network.HTTP.Media (MediaType, matches, parseAccept) import qualified Network.HTTP.Media as M import qualified Network.HTTP.Media as Media @@ -98,7 +98,6 @@ import Servant.API.ContentTypes ( AllMime (allMime) , AllMimeUnrender (allMimeUnrender) , EventStream - , contentTypes ) import Servant.API.Generic ( GenericMode (..) @@ -119,7 +118,7 @@ import Servant.API.ServerSentEvents ( EventKind (JsonEvent, RawEvent) , ServerSentEvents' ) -import Servant.API.Status (statusFromNat) +import Servant.API.Status (KnownStatus) import Servant.API.Stream (NoFraming) import Servant.API.TypeErrors import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) @@ -299,129 +298,65 @@ instance hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy sublayout) f . cl instance --- Note [Non-Empty Content Types] - {-# OVERLAPPABLE #-} - ( KnownNat status - , MimeUnrender ct a + ( HasClientContentCheck ctypes , ReflectMethod method + , ResponseListUnrender ctypes '[Respond status "" a] , RunClient m - , cts' ~ (ct ': cts) ) - => HasClient m (Verb method status cts' a) + => HasClient m (Verb method status ctypes a) where - type Client m (Verb method status cts' a) = m a - clientWithRoute _pm Proxy req = do - response <- - runRequestAcceptStatus - (Just [status]) - req - { requestAccept = fromList $ toList accept - , requestMethod = method - } - response `decodedAs` (Proxy :: Proxy ct) - where - accept = contentTypes (Proxy :: Proxy ct) - method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) - + type Client m (Verb method status ctypes a) = m a + clientWithRoute pm Proxy = clientWithRoute pm (Proxy @(MultiVerb method ctypes '[Respond status "" a] a)) hoistClientMonad _ _ f = f instance {-# OVERLAPPING #-} - ( KnownNat status + ( KnownStatus status , ReflectMethod method , RunClient m ) - => HasClient m (Verb method status cts NoContent) + => HasClient m (Verb method status ctypes NoContent) where - type - Client m (Verb method status cts NoContent) = - m NoContent - clientWithRoute _pm Proxy req = do - _response <- runRequestAcceptStatus (Just [status]) req{requestMethod = method} - pure NoContent - where - method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) - - hoistClientMonad _ _ f = f - -instance - (ReflectMethod method, RunClient m) - => HasClient m (NoContentVerb method) - where - type - Client m (NoContentVerb method) = - m NoContent - clientWithRoute _pm Proxy req = do - _response <- runRequest req{requestMethod = method} - pure NoContent - where - method = reflectMethod (Proxy :: Proxy method) - + type Client m (Verb method status ctypes NoContent) = m NoContent + clientWithRoute pm Proxy req = + NoContent + <$ clientWithRoute pm (Proxy @(MultiVerb method '() '[RespondAs '() status "" ()] ())) req hoistClientMonad _ _ f = f instance --- Note [Non-Empty Content Types] - {-# OVERLAPPING #-} - ( BuildHeadersTo ls - , KnownNat status - , MimeUnrender ct a + ( HasClientContentCheck ctypes , ReflectMethod method + , ResponseListUnrender ctypes '[WithHeaders h (Headers h a) (Respond status "" a)] , RunClient m - , cts' ~ (ct ': cts) ) - => HasClient m (Verb method status cts' (Headers ls a)) + => HasClient m (Verb method status ctypes (Headers h a)) where - type - Client m (Verb method status cts' (Headers ls a)) = - m (Headers ls a) - clientWithRoute _pm Proxy req = do - response <- - runRequestAcceptStatus - (Just [status]) - req - { requestMethod = method - , requestAccept = fromList $ toList accept - } - val <- response `decodedAs` (Proxy :: Proxy ct) - pure $ - Headers - { getResponse = val - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - where - method = reflectMethod (Proxy :: Proxy method) - accept = contentTypes (Proxy :: Proxy ct) - status = statusFromNat (Proxy :: Proxy status) - + type Client m (Verb method status ctypes (Headers h a)) = m (Headers h a) + clientWithRoute pm Proxy = clientWithRoute pm (Proxy @(MultiVerb method ctypes '[WithHeaders h (Headers h a) (Respond status "" a)] (Headers h a))) hoistClientMonad _ _ f = f instance {-# OVERLAPPING #-} - ( BuildHeadersTo ls - , KnownNat status - , ReflectMethod method + ( ReflectMethod method + , ResponseListUnrender '() '[WithHeaders h (Headers h NoContent) (RespondAs '() status "" ())] , RunClient m ) - => HasClient m (Verb method status cts (Headers ls NoContent)) + => HasClient m (Verb method status ctypes (Headers h NoContent)) where - type - Client m (Verb method status cts (Headers ls NoContent)) = - m (Headers ls NoContent) - clientWithRoute _pm Proxy req = do - response <- runRequestAcceptStatus (Just [status]) req{requestMethod = method} - pure $ - Headers - { getResponse = NoContent - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - where - method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) + type Client m (Verb method status ctypes (Headers h NoContent)) = m (Headers h NoContent) + clientWithRoute pm Proxy = clientWithRoute pm (Proxy @(MultiVerb method '() '[WithHeaders h (Headers h NoContent) (RespondAs '() status "" ())] (Headers h NoContent))) + hoistClientMonad _ _ f = f +instance + (ReflectMethod method, RunClient m) + => HasClient m (NoContentVerb method) + where + type Client m (NoContentVerb method) = m NoContent + clientWithRoute pm Proxy req = + NoContent + <$ clientWithRoute pm (Proxy @(MultiVerb method '() '[RespondAs '() 204 "" ()] ())) req hoistClientMonad _ _ f = f data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus @@ -1226,9 +1161,21 @@ x // f = f x (/:) :: (a -> b -> c) -> b -> a -> c (/:) = flip +class HasClientContentCheck cs where + clientAcceptList :: Proxy cs -> [M.MediaType] + clientContentTypeOk :: Proxy cs -> M.MediaType -> Bool + +instance AllMime cs => HasClientContentCheck cs where + clientAcceptList = allMime + clientContentTypeOk p c = any (M.matches c) (allMime p) + +instance HasClientContentCheck '() where + clientAcceptList _ = [] + clientContentTypeOk _ _ = True + instance - ( AllMime cs - , AsUnion as r + ( AsUnion as r + , HasClientContentCheck cs , ReflectMethod method , ResponseListUnrender cs as , RunClient m @@ -1247,7 +1194,7 @@ instance } c <- getResponseContentType response - unless (any (M.matches c) accept) $ do + unless (clientContentTypeOk (Proxy @cs) c) $ do throwClientError $ UnsupportedContentType c response -- NOTE: support streaming in the future @@ -1260,7 +1207,7 @@ instance UnrenderError e -> throwClientError (DecodeFailure (Text.pack e) response) UnrenderSuccess x -> pure (fromUnion @as x) where - accept = allMime (Proxy @cs) + accept = clientAcceptList (Proxy @cs) method = reflectMethod (Proxy @method) hoistClientMonad _ _ f = f @@ -1301,23 +1248,6 @@ checkContentTypeHeader response = Nothing -> throwClientError $ InvalidContentTypeHeader response Just t' -> pure t' -decodedAs - :: forall ct a m - . (MimeUnrender ct a, RunClient m) - => Response - -> Proxy ct - -> m a -decodedAs response@Response{responseBody = body} ct = do - responseContentType <- checkContentTypeHeader response - unless (any (matches responseContentType) accept) $ - throwClientError $ - UnsupportedContentType responseContentType response - case mimeUnrender ct body of - Left err -> throwClientError $ DecodeFailure (T.pack err) response - Right val -> pure val - where - accept = toList $ contentTypes ct - ------------------------------------------------------------------------------- -- Custom type errors ------------------------------------------------------------------------------- diff --git a/servant/src/Servant/API/MultiVerb.hs b/servant/src/Servant/API/MultiVerb.hs index f885abe52..8dcfa4fd2 100644 --- a/servant/src/Servant/API/MultiVerb.hs +++ b/servant/src/Servant/API/MultiVerb.hs @@ -55,7 +55,9 @@ import Generics.SOP as GSOP import Network.HTTP.Types as HTTP import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) +import Servant.API.ContentTypes (NoContent (..)) import Servant.API.Header (Header') +import Servant.API.ResponseHeaders (HList (..), Headers (..), ResponseHeader (..)) import Servant.API.Stream (SourceIO) import Servant.API.TypeLevel.List import Servant.API.UVerb.Union (Union) @@ -155,6 +157,32 @@ instance AsHeaders '[a, b] () (a, b) where toHeaders (h1, h2) = (I h1 :* I h2 :* Nil, ()) fromHeaders (I h1 :* I h2 :* Nil, ()) = (h1, h2) +-- | Convert between NP I xs (n-ary product of values) and HList hs (ResponseHeader-wrapped values) +-- The functional dependency hs -> xs means: given a header spec list, we know the value types +class NPToHList xs hs | hs -> xs where + npToHList :: NP I xs -> HList hs + hlistToNP :: HList hs -> NP I xs + +instance NPToHList '[] '[] where + npToHList Nil = HNil + hlistToNP HNil = Nil + +instance NPToHList xs hs => NPToHList (x ': xs) (Header' mods name x ': hs) where + npToHList (I x :* rest) = Header x `HCons` npToHList rest + hlistToNP (Header x `HCons` rest) = I x :* hlistToNP rest + hlistToNP (MissingHeader `HCons` _) = error "NPToHList: MissingHeader (should not happen)" + hlistToNP (UndecodableHeader _ `HCons` _) = error "NPToHList: UndecodableHeader (should not happen)" + +-- | Headers from Servant.API.ResponseHeaders, for backward compatibility with Verb +instance {-# OVERLAPPABLE #-} NPToHList xs hs => AsHeaders xs a (Headers hs a) where + fromHeaders (np, body) = Headers{getResponse = body, getHeadersHList = npToHList np} + toHeaders (Headers body hlist) = (hlistToNP hlist, body) + +-- | Special case for NoContent body - the underlying response is () but we return NoContent +instance {-# OVERLAPPING #-} NPToHList xs hs => AsHeaders xs () (Headers hs NoContent) where + fromHeaders (np, ()) = Headers{getResponse = NoContent, getHeadersHList = npToHList np} + toHeaders (Headers NoContent hlist) = (hlistToNP hlist, ()) + data DescHeader (name :: Symbol) (description :: Symbol) (a :: Type) -- | A wrapper to turn a response header into an optional one. From 9b196a11c5fabb27ac5ee9124483dcab90d0ae61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Fri, 12 Dec 2025 21:13:18 +0100 Subject: [PATCH 5/5] Commenting out servant-openapi3 cookbook Currently failing due to Verb now fixing method to `StdMethod` --- cabal.project | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 265d33c81..0d130b649 100644 --- a/cabal.project +++ b/cabal.project @@ -51,7 +51,8 @@ packages: -- doc/cookbook/open-id-connect doc/cookbook/managed-resource doc/cookbook/infinite-streams - doc/cookbook/openapi3 + -- Commented out because servant-openapi3 doesn't build with new Verb using StdMethod + -- doc/cookbook/openapi3 doc/cookbook/expose-prometheus tests: True