RFC: Delegate Verb/NoContentVerb implementations to MultiVerb.

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

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

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

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