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)

Author: gdeest

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,82 +369,34 @@ 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
   where
   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
   where
   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 #-}

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

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.

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
 

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