Response with Head to all Get requests

Signed-off-by: Brandon Martin <zmbmartin@gmail.com>

servant-server/src/Servant/Server/Internal.hs

@@ -25,10 +25,11 @@ import           Control.Applicative         ((<$>))
 #endif
 import           Control.Monad.Trans.Either  (EitherT)
 import qualified Data.ByteString             as B
+import qualified Data.ByteString.Lazy        as BL
 import qualified Data.Map                    as M
 import           Data.Maybe                  (catMaybes, fromMaybe)
 import           Data.String                 (fromString)
-import           Data.String.Conversions     (cs, (<>))
+import           Data.String.Conversions     (cs, (<>), ConvertibleStrings)
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
 import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
@@ -39,7 +40,8 @@ import           Network.Socket              (SockAddr)
 import           Network.Wai                 (Application, lazyRequestBody,
                                               rawQueryString, requestHeaders,
                                               requestMethod, responseLBS, remoteHost,
-                                              isSecure, vault, httpVersion)
+                                              isSecure, vault, httpVersion, Response,
+                                              Request)
 import           Servant.API                 ((:<|>) (..), (:>), Capture,
                                               Delete, Get, Header,
                                               IsSecure(..), MatrixFlag, MatrixParam,
@@ -121,6 +123,24 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
                Just v   -> feedTo subserver v)
     where captureProxy = Proxy :: Proxy (Capture capture a)
 
+allowedMethodHead :: Method -> Request -> Bool
+allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
+
+allowedMethod :: Method -> Request -> Bool
+allowedMethod method request = allowedMethodHead method request || requestMethod request == method
+
+processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
+                    => Maybe (a, BL.ByteString) -> Status -> Method
+                    -> Maybe [(HeaderName, B.ByteString)]
+                    -> Request -> RouteResult Response
+processMethodRouter handleA status method headers request = case handleA of
+  Nothing -> failWith UnsupportedMediaType
+  Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
+    where
+      bdy = case allowedMethodHead method request of
+        True -> ""
+        False -> body
+      hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
 
 methodRouter :: (AllCTRender ctypes a)
              => Method -> Proxy ctypes -> Status
@@ -129,13 +149,11 @@ methodRouter :: (AllCTRender ctypes a)
 methodRouter method proxy status action = LeafRouter route'
   where
     route' request respond
-      | pathIsEmpty request && requestMethod request == method = do
+      | pathIsEmpty request && allowedMethod method request = do
           runAction action respond $ \ output -> do
             let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-            case handleAcceptH proxy (AcceptHeader accH) output of
+                handleA = handleAcceptH proxy (AcceptHeader accH) output
-              Nothing -> failWith UnsupportedMediaType
+            processMethodRouter handleA status method Nothing request
-              Just (contentT, body) -> succeedWith $
-                responseLBS status [ ("Content-Type" , cs contentT)] body
       | pathIsEmpty request && requestMethod request /= method =
           respond $ failWith WrongMethod
       | otherwise = respond $ failWith NotFound
@@ -147,14 +165,12 @@ methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
 methodRouterHeaders method proxy status action = LeafRouter route'
   where
     route' request respond
-      | pathIsEmpty request && requestMethod request == method = do
+      | pathIsEmpty request && allowedMethod method request = do
         runAction action respond $ \ output -> do
           let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
               headers = getHeaders output
-          case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
+              handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
-            Nothing -> failWith UnsupportedMediaType
+          processMethodRouter handleA status method (Just headers) request
-            Just (contentT, body) -> succeedWith $
-              responseLBS status ( ("Content-Type" , cs contentT) : headers) body
       | pathIsEmpty request && requestMethod request /= method =
           respond $ failWith WrongMethod
       | otherwise = respond $ failWith NotFound
@@ -165,7 +181,7 @@ methodRouterEmpty :: Method
 methodRouterEmpty method action = LeafRouter route'
   where
     route' request respond
-      | pathIsEmpty request && requestMethod request == method = do
+      | pathIsEmpty request && allowedMethod method request = do
           runAction action respond $ \ () ->
             succeedWith $ responseLBS noContent204 [] ""
       | pathIsEmpty request && requestMethod request /= method =
@@ -612,7 +628,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
                   values = catMaybes $ map (convert . snd) parameters
               route (Proxy :: Proxy sublayout) (feedTo subserver values)
       _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
-
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
           convert Nothing = Nothing
@@ -644,11 +659,8 @@ instance (KnownSymbol sym, HasServer sublayout)
                     Just Nothing  -> True  -- param is there, with no value
                     Just (Just v) -> examine v -- param with a value
                     Nothing       -> False -- param not in the query string
-  
               route (Proxy :: Proxy sublayout) (feedTo subserver param)
-  
       _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
-
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           examine v | v == "true" || v == "1" || v == "" = True
                     | otherwise = False

servant-server/test/Servant/ServerSpec.hs

@@ -21,7 +21,7 @@ import           Data.String.Conversions    (cs)
 import qualified Data.Text                  as T
 import           GHC.Generics               (Generic)
 import           Network.HTTP.Types         (hAccept, hContentType,
-                                             methodDelete, methodGet,
+                                             methodDelete, methodGet, methodHead,
                                              methodPatch, methodPost, methodPut,
                                              ok200, parseQuery, status409)
 import           Network.Wai                (Application, Request, pathInfo,
@@ -33,7 +33,6 @@ import           Test.Hspec                 (Spec, describe, it, shouldBe)
 import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
                                              matchStatus, post, request,
                                              shouldRespondWith, with, (<:>))
-
 import           Servant.API                ((:<|>) (..), (:>),
                                              addHeader, Capture,
                                              Delete, Get, Header (..), Headers,
@@ -82,6 +81,7 @@ spec :: Spec
 spec = do
   captureSpec
   getSpec
+  headSpec
   postSpec
   putSpec
   patchSpec
@@ -127,13 +127,14 @@ captureSpec = do
 
 type GetApi = Get '[JSON] Person
         :<|> "empty" :> Get '[] ()
+        :<|> "post" :> Post '[] ()
 getApi :: Proxy GetApi
 getApi = Proxy
 
 getSpec :: Spec
 getSpec = do
   describe "Servant.API.Get" $ do
-    let server = return alice :<|> return ()
+    let server = return alice :<|> return () :<|> return ()
     with (return $ serve getApi server) $ do
 
       it "allows to GET a Person" $ do
@@ -146,13 +147,40 @@ getSpec = do
         post "/empty" "" `shouldRespondWith` 405
 
       it "returns 204 if the type is '()'" $ do
-        get "empty" `shouldRespondWith` ""{ matchStatus = 204 }
+        get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
 
       it "returns 415 if the Accept header is not supported" $ do
         Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
           `shouldRespondWith` 415
 
 
+headSpec :: Spec
+headSpec = do
+  describe "Servant.API.Head" $ do
+    let server = return alice :<|> return () :<|> return ()
+    with (return $ serve getApi server) $ do
+
+      it "allows to GET a Person" $ do
+        response <- Test.Hspec.Wai.request methodHead "/" [] ""
+        return response `shouldRespondWith` 200
+        liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)
+
+      it "does not allow HEAD to POST route" $ do
+        response <- Test.Hspec.Wai.request methodHead "/post" [] ""
+        return response `shouldRespondWith` 405
+
+      it "throws 405 (wrong method) on POSTs" $ do
+        post "/" "" `shouldRespondWith` 405
+        post "/empty" "" `shouldRespondWith` 405
+
+      it "returns 204 if the type is '()'" $ do
+        response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
+        return response `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "returns 415 if the Accept header is not supported" $ do
+        Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
+          `shouldRespondWith` 415
+
 
 type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
                 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person