Add support for HEAD request

CHANGELOG.md

@@ -7,6 +7,8 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ### Added
 
+- #1383, Add support for HEAD request - @steve-chavez
+
 ### Fixed
 
 ## [6.0.2] - 2019-08-22

src/PostgREST/ApiRequest.hs

@@ -6,6 +6,7 @@ Description : PostgREST functions to translate HTTP request to a domain type cal
 
 module PostgREST.ApiRequest (
   ApiRequest(..)
+, InvokeMethod(..)
 , ContentType(..)
 , Action(..)
 , Target(..)
@@ -51,11 +52,12 @@ import Protolude
 
 type RequestBody = BL.ByteString
 
+data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
 -- | Types of things a user wants to do to tables/views/procs
-data Action = ActionCreate  | ActionRead
+data Action = ActionCreate       | ActionRead{isHead :: Bool}
-            | ActionUpdate  | ActionDelete
+            | ActionUpdate       | ActionDelete
-            | ActionInfo    | ActionInvoke{isReadOnly :: Bool}
+            | ActionSingleUpsert | ActionInvoke InvokeMethod
-            | ActionInspect | ActionSingleUpsert
+            | ActionInfo         | ActionInspect{isHead :: Bool}
             deriving Eq
 -- | The target db object of a user action
 data Target = TargetIdent QualifiedIdentifier
@@ -117,7 +119,7 @@ data ApiRequest = ApiRequest {
 -- | Examines HTTP request and translates it into user intent.
 userApiRequest :: Schema -> Maybe QualifiedIdentifier -> Request -> RequestBody -> Either ApiRequestError ApiRequest
 userApiRequest schema rootSpec req reqBody
-  | isTargetingProc && method `notElem` ["GET", "POST"] = Left ActionInappropriate
+  | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate
   | topLevelRange == emptyRange = Left InvalidRange
   | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload
   | otherwise = Right ApiRequest {
@@ -152,8 +154,10 @@ userApiRequest schema rootSpec req reqBody
   -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)
   (filters, rpcQParams) =
     case action of
-      ActionInvoke{isReadOnly=True} -> partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
+      ActionInvoke InvGet  -> partitionFlts
-      _ -> (flts, [])
+      ActionInvoke InvHead -> partitionFlts
+      _                    -> (flts, [])
+  partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
   flts =
     [ (toS k, toS $ fromJust v) |
       (k,v) <- qParams, isJust v,
@@ -167,12 +171,13 @@ userApiRequest schema rootSpec req reqBody
     TargetProc _ _ -> True
     _              -> False
   contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
-  columns | action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}] = toS <$> join (lookup "columns" qParams)
+  columns
-          | otherwise = Nothing
+    | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
+    | otherwise = Nothing
   payload =
     case (contentType, action) of
-      (_, ActionInvoke{isReadOnly=True}) ->
+      (_, ActionInvoke InvGet)  -> Right rpcPrmsToJson
-        Right $ ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)
+      (_, ActionInvoke InvHead) -> Right rpcPrmsToJson
       (CTApplicationJSON, _) ->
         if isJust columns
           then Right $ RawJSON reqBody
@@ -189,21 +194,27 @@ userApiRequest schema rootSpec req reqBody
         Right $ ProcessedJSON (JSON.encode json) PJObject keys
       (ct, _) ->
         Left $ toS $ "Content-Type not acceptable: " <> toMime ct
+  rpcPrmsToJson = ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams)
+                  PJObject (S.fromList $ fst <$> rpcQParams)
   topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows
   action =
     case method of
-      "GET"      | target == TargetDefaultSpec -> ActionInspect
+      -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response
-                 | isTargetingProc -> ActionInvoke{isReadOnly=True}
+      -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4
-                 | otherwise -> ActionRead
+      "HEAD"     | target == TargetDefaultSpec -> ActionInspect{isHead=True}
-
+                 | isTargetingProc             -> ActionInvoke InvHead
+                 | otherwise                   -> ActionRead{isHead=True}
+      "GET"      | target == TargetDefaultSpec -> ActionInspect{isHead=False}
+                 | isTargetingProc             -> ActionInvoke InvGet
+                 | otherwise                   -> ActionRead{isHead=False}
       "POST"    -> if isTargetingProc
-                    then ActionInvoke{isReadOnly=False}
+                    then ActionInvoke InvPost
                     else ActionCreate
       "PATCH"   -> ActionUpdate
       "PUT"     -> ActionSingleUpsert
       "DELETE"  -> ActionDelete
       "OPTIONS" -> ActionInfo
-      _         -> ActionInspect
+      _         -> ActionInspect{isHead=False}
   target = case path of
     []            -> case rootSpec of
                        Just rsQi -> TargetProc rsQi True
@@ -212,7 +223,14 @@ userApiRequest schema rootSpec req reqBody
     ["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False
     other         -> TargetUnknown other
 
-  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}]
+  shouldParsePayload =
+    action `elem`
+    [ActionCreate, ActionUpdate, ActionSingleUpsert,
+    ActionInvoke InvPost,
+    -- Though ActionInvoke{isGet=True}(a GET /rpc/..) doesn't really have a payload, we use the payload variable as a way
+    -- to store the query string arguments to the function.
+    ActionInvoke InvGet,
+    ActionInvoke InvHead]
   relevantPayload | shouldParsePayload = rightToMaybe payload
                   | otherwise = Nothing
   path            = pathInfo req

src/PostgREST/App.hs

@@ -41,6 +41,7 @@ import Network.Wai
 
 import PostgREST.ApiRequest       (Action (..), ApiRequest (..),
                                    ContentType (..),
+                                   InvokeMethod (..),
                                    PreferRepresentation (..),
                                    Target (..), mutuallyAgreeable,
                                    userApiRequest)
@@ -55,12 +56,12 @@ import PostgREST.Error            (PgError (..), SimpleError (..),
 import PostgREST.Middleware
 import PostgREST.OpenAPI
 import PostgREST.Parsers          (pRequestColumns)
-import PostgREST.QueryBuilder     (callProc,
+import PostgREST.QueryBuilder     (callProc, createReadStatement,
-                                   createReadStatement,
                                    createWriteStatement,
                                    requestToCountQuery,
                                    requestToQuery)
-import PostgREST.RangeQuery       (allRange, contentRangeH, rangeStatusHeader)
+import PostgREST.RangeQuery       (allRange, contentRangeH,
+                                   rangeStatusHeader)
 import PostgREST.Types
 import Protolude                  hiding (Proxy, intercalate)
 
@@ -101,15 +102,16 @@ postgrest conf refDbStructure pool getTime worker =
 transactionMode :: Maybe ProcDescription -> Action -> HT.Mode
 transactionMode proc action =
   case action of
-    ActionRead -> HT.Read
+    ActionRead _         -> HT.Read
-    ActionInfo -> HT.Read
+    ActionInfo           -> HT.Read
-    ActionInspect -> HT.Read
+    ActionInspect _      -> HT.Read
-    ActionInvoke{isReadOnly=False} ->
+    ActionInvoke InvGet  -> HT.Read
+    ActionInvoke InvHead -> HT.Read
+    ActionInvoke InvPost ->
       let v = maybe Volatile pdVolatility proc in
       if v == Stable || v == Immutable
          then HT.Read
          else HT.Write
-    ActionInvoke{isReadOnly=True} -> HT.Read
     _ -> HT.Write
 
 app :: DbStructure -> Maybe ProcDescription -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response
@@ -119,7 +121,7 @@ app dbStructure proc cols conf apiRequest =
     Right contentType ->
       case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
 
-        (ActionRead, TargetIdent qi, Nothing) ->
+        (ActionRead headersOnly, TargetIdent qi, Nothing) ->
           let partsField = (,) <$> readSqlParts
                 <*> (binaryField contentType rawContentTypes =<< fldNames) in
           case partsField of
@@ -135,7 +137,8 @@ app dbStructure proc cols conf apiRequest =
                   then errorResponseFor . singularityError $ queryTotal
                   else responseLBS status
                     [toHeader contentType, contentRange,
-                     contentLocationH (qiName qi) (iCanonicalQS apiRequest)] (toS body)
+                     contentLocationH (qiName qi) (iCanonicalQS apiRequest)]
+                    (if headersOnly then mempty else toS body)
 
         (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->
           case mutateSqlParts tSchema tName of
@@ -266,7 +269,7 @@ app dbStructure proc cols conf apiRequest =
                   allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in
               return $ responseLBS status200 [allOrigins, allowH] mempty
 
-        (ActionInvoke _, TargetProc qi _, Just pJson) ->
+        (ActionInvoke invMethod, TargetProc qi _, Just pJson) ->
           let returnsScalar = case proc of
                 Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True
                 _ -> False
@@ -294,9 +297,11 @@ app dbStructure proc cols conf apiRequest =
                     then do
                       HT.condemn
                       return . errorResponseFor . singularityError $ queryTotal
-                    else return $ responseLBS status ([toHeader contentType, contentRange] ++ toHeaders hs) (toS body)
+                    else
+                      return $ responseLBS status ([toHeader contentType, contentRange] ++ toHeaders hs)
+                      (if invMethod == InvHead then mempty else toS body)
 
-        (ActionInspect, TargetDefaultSpec, Nothing) -> do
+        (ActionInspect headersOnly, TargetDefaultSpec, Nothing) -> do
           let host = configHost conf
               port = toInteger $ configPort conf
               proxy = pickProxy $ toS <$> configProxyUri conf
@@ -308,7 +313,7 @@ app dbStructure proc cols conf apiRequest =
               encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure
 
           body <- encodeApi <$> H.statement schema accessibleTables <*> H.statement schema schemaDescription <*> H.statement schema accessibleProcs
-          return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
+          return $ responseLBS status200 [toHeader CTOpenAPI] (if headersOnly then mempty else toS body)
 
         _ -> return notFound
 
@@ -335,7 +340,7 @@ responseContentTypeOrError :: [ContentType] -> [ContentType] -> Action -> Target
 responseContentTypeOrError accepts rawContentTypes action target = serves contentTypesForRequest accepts
   where
     contentTypesForRequest = case action of
-      ActionRead         ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+      ActionRead _       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
                              ++ rawContentTypes
       ActionCreate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
       ActionUpdate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
@@ -343,7 +348,7 @@ responseContentTypeOrError accepts rawContentTypes action target = serves conten
       ActionInvoke _     ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
                              ++ rawContentTypes
                              ++ [CTOpenAPI | tpIsRootSpec target]
-      ActionInspect      ->  [CTOpenAPI, CTApplicationJSON]
+      ActionInspect _    ->  [CTOpenAPI, CTApplicationJSON]
       ActionInfo         ->  [CTTextCSV]
       ActionSingleUpsert ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
     serves sProduces cAccepts =

src/PostgREST/DbRequestBuilder.hs

@@ -72,7 +72,9 @@ readRequest maxRows allRels proc apiRequest  =
     buildReadRequest :: [Tree SelectItem] -> ReadRequest
     buildReadRequest fieldTree =
       let rootDepth = 0
-          rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in
+          rootNodeName = case action of
+            ActionRead _ -> rootTableName
+            _            -> sourceCTEName in
       foldr (treeEntry rootDepth) (Node (Select [] rootNodeName Nothing [] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing, rootDepth)) []) fieldTree
       where
         treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest
@@ -278,7 +280,7 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
     (flts, logFrst) =
       case action of
         ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)
-        ActionRead     -> (iFilters apiRequest, iLogic apiRequest)
+        ActionRead _   -> (iFilters apiRequest, iLogic apiRequest)
         _              -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
     orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
     orders = mapM pRequestOrder $ iOrder apiRequest

test/Feature/RangeSpec.hs

@@ -155,12 +155,17 @@ spec = do
           , matchHeaders = ["Content-Range" <:> "0-0/*"]
           }
 
-      it "limit and offset works on first level" $
+      it "limit and offset works on first level" $ do
         get "/items?select=id&order=id.asc&limit=3&offset=2"
           `shouldRespondWith` [json|[{"id":3},{"id":4},{"id":5}]|]
           { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "2-4/*"]
           }
+        request methodHead "/items?select=id&order=id.asc&limit=3&offset=2" [] mempty
+          `shouldRespondWith` ""
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "2-4/*"]
+          }
 
       it "succeeds if offset equals 0 as a no-op" $
         get "/items?select=id&offset=0"

test/Feature/RpcSpec.hs

@@ -34,6 +34,12 @@ spec actualPgVersion =
             { matchStatus = 200
             , matchHeaders = ["Content-Range" <:> "0-0/*"]
             }
+        request methodHead "/rpc/getitemrange?min=2&max=4"
+                (rangeHdrs (ByteRangeFromTo 0 0)) ""
+           `shouldRespondWith` ""
+            { matchStatus = 200
+            , matchHeaders = ["Content-Range" <:> "0-0/*"]
+            }
 
       it "includes total count if requested" $ do
         request methodPost "/rpc/getitemrange"
@@ -49,6 +55,12 @@ spec actualPgVersion =
             { matchStatus = 206
             , matchHeaders = ["Content-Range" <:> "0-0/2"]
             }
+        request methodHead "/rpc/getitemrange?min=2&max=4"
+                (rangeHdrsWithCount (ByteRangeFromTo 0 0)) ""
+           `shouldRespondWith` ""
+            { matchStatus = 206
+            , matchHeaders = ["Content-Range" <:> "0-0/2"]
+            }
 
       it "returns proper json" $ do
         post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`
@@ -72,6 +84,12 @@ spec actualPgVersion =
             { matchStatus = 200
             , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
             }
+        request methodHead "/rpc/getitemrange?min=2&max=4"
+                (acceptHdrs "text/csv") ""
+           `shouldRespondWith` ""
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
+            }
 
     context "unknown function" $ do
       it "returns 404" $

test/Feature/StructureSpec.hs

@@ -21,8 +21,10 @@ spec :: SpecWith Application
 spec = do
 
   describe "OpenAPI" $ do
-    it "root path returns a valid openapi spec" $
+    it "root path returns a valid openapi spec" $ do
       validateOpenApiResponse [("Accept", "application/openapi+json")]
+      request methodHead "/" (acceptHdrs "application/openapi+json") ""
+        `shouldRespondWith` "" { matchStatus  = 200 }
 
     it "should respond to openapi request on none root path with 415" $
       request methodGet "/items"