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.

Author: gdeest

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
 -------------------------------------------------------------------------------

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.