Include allow header in options response (#628)

CHANGELOG.md

@@ -13,6 +13,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 - Ability to order embedded entities - @ruslantalpa
 - Ability to paginate using &limit and &offset parameters - @ruslantalpa
 - Ability to apply limits to embedded entities and enforce --max-rows on all levels - @ruslantalpa, @begriffs
+- Add allow response header in OPTIONS - @begriffs
 
 ### Fixed
 - Return 401 or 403 for access denied rather than 404 - @begriffs

src/PostgREST/App.hs

@@ -11,7 +11,7 @@ import           Data.Bifunctor            (first)
 import qualified Data.ByteString.Char8   as BS
 import           Data.IORef                (IORef, readIORef)
 import           Data.List                 (find, delete)
-import           Data.Maybe                (isJust, fromMaybe, fromJust, mapMaybe)
+import           Data.Maybe                (fromMaybe, fromJust, mapMaybe)
 import           Data.Ranged.Ranges        (emptyRange)
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
@@ -173,16 +173,18 @@ app dbStructure conf apiRequest =
               else responseLBS status204 [r] ""
 
     (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
-      if isJust $ find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure)
-        then let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
-                 pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
-                 body = encode (TableOptions cols pkeys)
-                 filterCol :: Schema -> TableName -> Column -> Bool
-                 filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
-                 filterCol _ _ _ =  False in
-          return $ responseLBS status200 [jsonH, allOrigins] $ cs body
-        else
-          return notFound
+      let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
+      case mTable of
+        Nothing -> return notFound
+        Just table ->
+          let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+              pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+              body = encode (TableOptions cols pkeys)
+              filterCol :: Schema -> TableName -> Column -> Bool
+              filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
+              filterCol _ _ _ =  False
+              acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
+          return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ cs body
 
     (ActionInvoke, TargetProc qi,
      Just (PayloadJSON (UniformObjects payload))) -> do

test/Feature/StructureSpec.hs

@@ -8,6 +8,7 @@ import SpecHelper
 
 import Network.HTTP.Types
 import Network.Wai (Application)
+import Network.Wai.Test (SResponse(simpleHeaders))
 
 spec :: SpecWith Application
 spec = do
@@ -382,3 +383,17 @@ spec = do
 
     it "errors for non existant tables" $
       request methodOptions "/dne" [] "" `shouldRespondWith` 404
+
+  describe "Allow header" $ do
+
+    it "includes read/write verbs for writeable table" $ do
+      r <- request methodOptions "/items" [] ""
+      liftIO $
+        simpleHeaders r `shouldSatisfy`
+          matchHeader "Allow" "GET,POST,PATCH,DELETE"
+
+    it "includes read verbs for read-only table" $ do
+      r <- request methodOptions "/has_count_column" [] ""
+      liftIO $
+        simpleHeaders r `shouldSatisfy`
+          matchHeader "Allow" "GET"