fix: Return 405 Method Not Allowed for unsupported verbs

Signed-off-by: Wolfgang Walther <walther@technowledgy.de>

postgrest.cabal

@@ -191,7 +191,7 @@ test-suite spec
                       Feature.Query.InsertSpec
                       Feature.Query.JsonOperatorSpec
                       Feature.Query.MultipleSchemaSpec
-                      Feature.Query.NonexistentSchemaSpec
+                      Feature.Query.ErrorSpec
                       Feature.Query.QueryLimitedSpec
                       Feature.Query.QuerySpec
                       Feature.Query.RangeSpec

src/PostgREST/App.hs

@@ -77,7 +77,7 @@ import PostgREST.GucHeader               (GucHeader,
 import PostgREST.Request.ApiRequest      (Action (..),
                                           ApiRequest (..),
                                           InvokeMethod (..),
-                                          Target (..))
+                                          Mutation (..), Target (..))
 import PostgREST.Request.Preferences     (PreferCount (..),
                                           PreferParameters (..),
                                           PreferRepresentation (..),
@@ -229,13 +229,13 @@ handleRequest context@(RequestContext _ _ ApiRequest{..} _) =
   case (iAction, iTarget) of
     (ActionRead headersOnly, TargetIdent identifier) ->
       handleRead headersOnly identifier context
-    (ActionCreate, TargetIdent identifier) ->
+    (ActionMutate MutationCreate, TargetIdent identifier) ->
       handleCreate identifier context
-    (ActionUpdate, TargetIdent identifier) ->
+    (ActionMutate MutationUpdate, TargetIdent identifier) ->
       handleUpdate identifier context
-    (ActionSingleUpsert, TargetIdent identifier) ->
+    (ActionMutate MutationSingleUpsert, TargetIdent identifier) ->
       handleSingleUpsert identifier context
-    (ActionDelete, TargetIdent identifier) ->
+    (ActionMutate MutationDelete, TargetIdent identifier) ->
       handleDelete identifier context
     (ActionInfo, TargetIdent identifier) ->
       handleInfo identifier context
@@ -243,6 +243,8 @@ handleRequest context@(RequestContext _ _ ApiRequest{..} _) =
       handleInvoke invMethod proc context
     (ActionInspect headersOnly, TargetDefaultSpec tSchema) ->
       handleOpenApi headersOnly tSchema context
+    (ActionUnknown verb, _) ->
+      throwError $ Error.UnsupportedVerb verb
     _ ->
       throwError Error.NotFound
 
@@ -313,7 +315,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
     ApiRequest{..} = ctxApiRequest
     pkCols = tablePKCols ctxDbStructure qiSchema qiName
 
-  WriteQueryResult{..} <- writeQuery identifier True pkCols context
+  WriteQueryResult{..} <- writeQuery MutationCreate identifier True pkCols context
 
   let
     response = gucResponse resGucStatus resGucHeaders
@@ -344,7 +346,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
 
 handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
 handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do
-  WriteQueryResult{..} <- writeQuery identifier False mempty context
+  WriteQueryResult{..} <- writeQuery MutationUpdate identifier False mempty context
 
   let
     response = gucResponse resGucStatus resGucHeaders
@@ -369,7 +371,7 @@ handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do
   when (iTopLevelRange /= RangeQuery.allRange) $
     throwError Error.PutRangeNotAllowedError
 
-  WriteQueryResult{..} <- writeQuery identifier False mempty context
+  WriteQueryResult{..} <- writeQuery MutationSingleUpsert identifier False mempty context
 
   let response = gucResponse resGucStatus resGucHeaders
 
@@ -390,7 +392,7 @@ handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do
 
 handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
 handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do
-  WriteQueryResult{..} <- writeQuery identifier False mempty context
+  WriteQueryResult{..} <- writeQuery MutationDelete identifier False mempty context
 
   let
     response = gucResponse resGucStatus resGucHeaders
@@ -522,13 +524,13 @@ data WriteQueryResult = WriteQueryResult
   , resGucHeaders :: [GucHeader]
   }
 
-writeQuery :: QualifiedIdentifier -> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
+writeQuery :: Mutation -> QualifiedIdentifier -> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
-writeQuery identifier@QualifiedIdentifier{..} isInsert pkCols context@RequestContext{..} = do
+writeQuery mutation identifier@QualifiedIdentifier{..} isInsert pkCols context@RequestContext{..} = do
   readReq <- readRequest identifier context
 
   mutateReq <-
     liftEither $
-      ReqBuilder.mutateRequest qiSchema qiName ctxApiRequest
+      ReqBuilder.mutateRequest mutation qiSchema qiName ctxApiRequest
         (tablePKCols ctxDbStructure qiSchema qiName)
         readReq
 

src/PostgREST/Error.hs

@@ -68,7 +68,6 @@ instance PgrstError ApiRequestError where
   status ParseRequestError{}   = HTTP.status400
   status QueryParamError{}     = HTTP.status400
   status UnacceptableSchema{}  = HTTP.status406
-  status UnsupportedVerb       = HTTP.status405
 
   headers _ = [ContentType.toHeader CTApplicationJSON]
 
@@ -104,8 +103,6 @@ instance JSON.ToJSON ApiRequestError where
         (_, True, CTApplicationJSON) -> prms <> " function or the " <> schema <> "." <> procName <>" function with a single unnamed json or jsonb parameter"
         _                            -> prms <> " function") <>
       " in the schema cache")]
-  toJSON UnsupportedVerb = JSON.object [
-    "message" .= ("Unsupported HTTP verb" :: Text)]
   toJSON InvalidFilters = JSON.object [
     "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]
   toJSON (UnacceptableSchema schemas) = JSON.object [
@@ -283,6 +280,7 @@ data Error
   | PutMatchingPkError
   | PutRangeNotAllowedError
   | SingularityError Integer
+  | UnsupportedVerb Text
 
 instance PgrstError Error where
   status (ApiRequestError err)   = status err
@@ -298,6 +296,7 @@ instance PgrstError Error where
   status PutMatchingPkError      = HTTP.status400
   status PutRangeNotAllowedError = HTTP.status400
   status SingularityError{}      = HTTP.status406
+  status UnsupportedVerb{}       = HTTP.status405
 
   headers (ApiRequestError err)  = headers err
   headers (JwtTokenInvalid m)    = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m]
@@ -332,6 +331,8 @@ instance JSON.ToJSON Error where
   toJSON JwtTokenRequired          = JSON.object [
     "message" .= ("Anonymous access is disabled" :: Text)]
   toJSON NotFound = JSON.object []
+  toJSON (UnsupportedVerb verb) = JSON.object [
+    "message" .= ("Unsupported HTTP verb: " <> verb)]
   toJSON (PgErr err) = JSON.toJSON err
   toJSON (ApiRequestError err) = JSON.toJSON err
 

src/PostgREST/Request/ApiRequest.hs

@@ -9,6 +9,7 @@ Description : PostgREST functions to translate HTTP request to a domain type cal
 module PostgREST.Request.ApiRequest
   ( ApiRequest(..)
   , InvokeMethod(..)
+  , Mutation(..)
   , ContentType(..)
   , Action(..)
   , Target(..)
@@ -82,16 +83,16 @@ data Payload
   | RawPay  { payRaw  :: LBS.ByteString }
 
 data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
+data Mutation = MutationCreate | MutationDelete | MutationSingleUpsert | MutationUpdate deriving Eq
+
 -- | Types of things a user wants to do to tables/views/procs
 data Action
-  = ActionCreate
+  = ActionMutate Mutation
   | ActionRead {isHead :: Bool}
-  | ActionUpdate
-  | ActionDelete
-  | ActionSingleUpsert
   | ActionInvoke InvokeMethod
   | ActionInfo
   | ActionInspect {isHead :: Bool}
+  | ActionUnknown Text
   deriving Eq
 -- | The path info that will be mapped to a target (used to handle validations and errors before defining the Target)
 data Path
@@ -220,10 +221,10 @@ apiRequest conf@AppConfig{..} dbStructure req reqBody queryparams@QueryParams{..
   contentType = maybe CTApplicationJSON ContentType.decodeContentType $ lookupHeader "content-type"
 
   columns = case action of
-    ActionCreate -> qsColumns
+    ActionMutate MutationCreate -> qsColumns
-    ActionUpdate -> qsColumns
+    ActionMutate MutationUpdate -> qsColumns
-    ActionInvoke InvPost -> qsColumns
+    ActionInvoke InvPost        -> qsColumns
-    _ -> Nothing
+    _                           -> Nothing
 
   payloadColumns =
     case (contentType, action) of
@@ -265,25 +266,24 @@ apiRequest conf@AppConfig{..} dbStructure req reqBody queryparams@QueryParams{..
                  | otherwise              -> ActionRead{isHead=False}
       "POST"    -> if isTargetingProc
                     then ActionInvoke InvPost
-                    else ActionCreate
+                    else ActionMutate MutationCreate
-      "PATCH"   -> ActionUpdate
+      "PATCH"   -> ActionMutate MutationUpdate
-      "PUT"     -> ActionSingleUpsert
+      "PUT"     -> ActionMutate MutationSingleUpsert
-      "DELETE"  -> ActionDelete
+      "DELETE"  -> ActionMutate MutationDelete
       "OPTIONS" -> ActionInfo
-      _         -> ActionInspect{isHead=False}
+      _         -> ActionUnknown $ T.decodeUtf8 method
 
   defaultSchema = NonEmptyList.head configDbSchemas
   profile
     | length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config
       = Nothing
-    | otherwise = case action of
+    | otherwise = case method of
         -- POST/PATCH/PUT/DELETE don't use the same header as per the spec
-        ActionCreate         -> contentProfile
+        "DELETE" -> contentProfile
-        ActionUpdate         -> contentProfile
+        "PATCH"  -> contentProfile
-        ActionSingleUpsert   -> contentProfile
+        "POST"   -> contentProfile
-        ActionDelete         -> contentProfile
+        "PUT"    -> contentProfile
-        ActionInvoke InvPost -> contentProfile
+        _        -> acceptProfile
-        _                    -> acceptProfile
     where
       contentProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Content-Profile"
       acceptProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Accept-Profile"
@@ -302,12 +302,12 @@ apiRequest conf@AppConfig{..} dbStructure req reqBody queryparams@QueryParams{..
       PathUnknown -> Right TargetUnknown
 
   shouldParsePayload = case (action, contentType) of
-    (ActionCreate, _) -> True
+    (ActionMutate MutationCreate, _)       -> True
-    (ActionInvoke InvPost, CTUrlEncoded) -> False
+    (ActionInvoke InvPost, CTUrlEncoded)   -> False
-    (ActionInvoke InvPost, _) -> True
+    (ActionInvoke InvPost, _)              -> True
-    (ActionSingleUpsert, _) -> True
+    (ActionMutate MutationSingleUpsert, _) -> True
-    (ActionUpdate, _) -> True
+    (ActionMutate MutationUpdate, _)       -> True
-    _ -> False
+    _                                      -> False
   relevantPayload = case (contentType, action) of
     -- Though ActionInvoke GET/HEAD doesn't really have a payload, we use the payload variable as a way
     -- to store the query string arguments to the function.

src/PostgREST/Request/DbRequestBuilder.hs

@@ -46,6 +46,7 @@ import PostgREST.RangeQuery               (NonnegRange, allRange,
 import PostgREST.Request.ApiRequest       (Action (..),
                                            ApiRequest (..),
                                            InvokeMethod (..),
+                                           Mutation (..),
                                            Payload (..))
 
 import PostgREST.Request.Preferences
@@ -313,13 +314,13 @@ updateNode f (targetNodeName:remainingPath, a) (Right (Node rootNode forest)) =
     findNode :: Maybe ReadRequest
     findNode = find (\(Node (_,(nodeName,_,alias,_,_, _)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest
 
-mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest
+mutateRequest :: Mutation -> Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest
-mutateRequest schema tName ApiRequest{..} pkCols readReq = mapLeft ApiRequestError $
+mutateRequest mutation schema tName ApiRequest{..} pkCols readReq = mapLeft ApiRequestError $
-  case iAction of
+  case mutation of
-    ActionCreate ->
+    MutationCreate ->
       Right $ Insert qi iColumns body ((,) <$> iPreferResolution <*> Just confCols) [] returnings
-    ActionUpdate -> Right $ Update qi iColumns body combinedLogic returnings
+    MutationUpdate -> Right $ Update qi iColumns body combinedLogic returnings
-    ActionSingleUpsert ->
+    MutationSingleUpsert ->
         if null qsLogic &&
            qsFilterFields == S.fromList pkCols &&
            not (null (S.fromList pkCols)) &&
@@ -329,8 +330,7 @@ mutateRequest schema tName ApiRequest{..} pkCols readReq = mapLeft ApiRequestErr
           then Right $ Insert qi iColumns body (Just (MergeDuplicates, pkCols)) combinedLogic returnings
         else
           Left InvalidFilters
-    ActionDelete -> Right $ Delete qi combinedLogic returnings
+    MutationDelete -> Right $ Delete qi combinedLogic returnings
-    _            -> Left UnsupportedVerb
   where
     confCols = fromMaybe pkCols qsOnConflict
     QueryParams.QueryParams{..} = iQueryParams

src/PostgREST/Request/Types.hs

@@ -71,7 +71,6 @@ data ApiRequestError
   | ParseRequestError Text Text
   | QueryParamError QPError
   | UnacceptableSchema [Text]
-  | UnsupportedVerb                -- Unreachable?
 
 data QPError = QPError Text Text
 

test/spec/Feature/Query/ErrorSpec.hs

@@ -0,0 +1,44 @@
+module Feature.Query.ErrorSpec where
+
+import Network.Wai (Application)
+
+import Network.HTTP.Types
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+import Protolude hiding (get)
+
+spec :: SpecWith ((), Application)
+spec = do
+  describe "Non existent api schema" $ do
+    it "succeeds when requesting root path" $
+      get "/" `shouldRespondWith` 200
+
+    it "gives 404 when requesting a nonexistent table in this nonexistent schema" $
+      get "/nonexistent_table" `shouldRespondWith` 404
+
+  describe "Unsupported HTTP methods" $ do
+    it "should return 405 for CONNECT method" $
+      request methodConnect "/"
+          []
+          ""
+        `shouldRespondWith`
+          [json|{"message":"Unsupported HTTP verb: CONNECT"}|]
+          { matchStatus = 405 }
+
+    it "should return 405 for TRACE method" $
+      request methodTrace "/"
+          []
+          ""
+        `shouldRespondWith`
+          [json|{"message":"Unsupported HTTP verb: TRACE"}|]
+          { matchStatus = 405 }
+
+    it "should return 405 for OTHER method" $
+      request "OTHER" "/"
+          []
+          ""
+        `shouldRespondWith`
+          [json|{"message":"Unsupported HTTP verb: OTHER"}|]
+          { matchStatus = 405 }

test/spec/Feature/Query/NonexistentSchemaSpec.hs

@@ -1,17 +0,0 @@
-module Feature.Query.NonexistentSchemaSpec where
-
-import Network.Wai (Application)
-
-import Test.Hspec
-import Test.Hspec.Wai
-
-import Protolude hiding (get)
-
-spec :: SpecWith ((), Application)
-spec =
-  describe "Non existent api schema" $ do
-    it "succeeds when requesting root path" $
-      get "/" `shouldRespondWith` 200
-
-    it "gives 404 when requesting a nonexistent table in this nonexistent schema" $
-      get "/nonexistent_table" `shouldRespondWith` 404

test/spec/Main.hs

@@ -39,11 +39,11 @@ import qualified Feature.Query.AndOrParamsSpec
 import qualified Feature.Query.DeleteSpec
 import qualified Feature.Query.EmbedDisambiguationSpec
 import qualified Feature.Query.EmbedInnerJoinSpec
+import qualified Feature.Query.ErrorSpec
 import qualified Feature.Query.HtmlRawOutputSpec
 import qualified Feature.Query.InsertSpec
 import qualified Feature.Query.JsonOperatorSpec
 import qualified Feature.Query.MultipleSchemaSpec
-import qualified Feature.Query.NonexistentSchemaSpec
 import qualified Feature.Query.QueryLimitedSpec
 import qualified Feature.Query.QuerySpec
 import qualified Feature.Query.RangeSpec
@@ -198,7 +198,7 @@ main = do
 
     -- this test runs with a nonexistent db-schema
     parallel $ before nonexistentSchemaApp $
-      describe "Feature.Query.NonexistentSchemaSpec" Feature.Query.NonexistentSchemaSpec.spec
+      describe "Feature.Query.ErrorSpec" Feature.Query.ErrorSpec.spec
 
     -- this test runs with an extra search path
     parallel $ before extraSearchPathApp $