fix: Fix wrong CORS header Authentication -> Authorization

Also refactors defaultCorsPolicy and corsPolicy and cleans up CORS tests

CHANGELOG.md

@@ -16,6 +16,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
  - #2058, Return 204 No Content without Content-Type for PUT - @wolfgangwalther
  - #2077, Fix `is` not working with upper or mixed case values like `NULL, TrUe, FaLsE` - @steve-chavez
  - #2024, Fix schema cache loading when views with XMLTABLE and DEFAULT are present - @wolfgangwalther
+ - #1724, Fix wrong CORS header Authentication -> Authorization - @wolfgangwalther
 
 ## [9.0.0] - 2021-11-25
 

src/PostgREST/Middleware.hs

@@ -8,8 +8,6 @@ module PostgREST.Middleware
   ( runPgLocals
   , pgrstFormat
   , pgrstMiddleware
-  , defaultCorsPolicy
-  , corsPolicy
   , optionalRollback
   ) where
 
@@ -132,21 +130,21 @@ pgrstMiddleware logLevel =
       LogWarn  -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}
       LogInfo  -> Wai.logStdout
 
-defaultCorsPolicy :: Wai.CorsResourcePolicy
-defaultCorsPolicy =  Wai.CorsResourcePolicy Nothing
-  ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing
-  (Just $ 60*60*24) False False True
-
 -- | CORS policy to be used in by Wai Cors middleware
 corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy
 corsPolicy req = case lookup "origin" headers of
-  Just origin -> Just defaultCorsPolicy {
-      Wai.corsOrigins = Just ([origin], True)
-    , Wai.corsRequestHeaders = "Authentication" : accHeaders
-    , Wai.corsExposedHeaders = Just [
-        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
-      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
-      ]
+  Just origin ->
+    Just Wai.CorsResourcePolicy
+    { Wai.corsOrigins = Just ([origin], True)
+    , Wai.corsMethods = ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"]
+    , Wai.corsRequestHeaders = "Authorization" : accHeaders
+    , Wai.corsExposedHeaders = Just
+      [ "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
+      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"]
+    , Wai.corsMaxAge = Just $ 60*60*24
+    , Wai.corsVaryOrigin = False
+    , Wai.corsRequireOrigin = False
+    , Wai.corsIgnoreFailures = True
     }
   Nothing -> Nothing
   where

test/Feature/CorsSpec.hs

@@ -1,74 +1,56 @@
 module Feature.CorsSpec where
 
--- {{{ Imports
-import qualified Data.ByteString.Lazy as BL
-
-import Network.Wai      (Application)
-import Network.Wai.Test (SResponse (simpleBody, simpleHeaders))
+import Network.Wai (Application)
 
 import Network.HTTP.Types
 import Test.Hspec
 import Test.Hspec.Wai
 
 import Protolude
-import SpecHelper
--- }}}
 
 spec :: SpecWith ((), Application)
 spec =
   describe "CORS" $ do
-    let preflightHeaders = [
-          ("Accept", "*/*"),
-          ("Origin", "http://example.com"),
-          ("Access-Control-Request-Method", "POST"),
-          ("Access-Control-Request-Headers", "Foo,Bar") ]
-    let normalCors = [
-          ("Host", "localhost:3000"),
-          ("User-Agent", "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.9; rv:32.0) Gecko/20100101 Firefox/32.0"),
-          ("Origin", "http://localhost:8000"),
-          ("Accept", "text/csv, */*; q=0.01"),
-          ("Accept-Language", "en-US,en;q=0.5"),
-          ("Accept-Encoding", "gzip, deflate"),
-          ("Referer", "http://localhost:8000/"),
-          ("Connection", "keep-alive") ]
+    it "replies naively and permissively to preflight request" $
+      request methodOptions "/"
+          [ ("Accept", "*/*")
+          , ("Origin", "http://example.com")
+          , ("Access-Control-Request-Method", "POST")
+          , ("Access-Control-Request-Headers", "Foo,Bar") ]
+          ""
+        `shouldRespondWith`
+          ""
+          { matchHeaders = [ "Access-Control-Allow-Origin" <:> "http://example.com"
+                           , "Access-Control-Allow-Credentials" <:> "true"
+                           , "Access-Control-Allow-Methods" <:> "GET, POST, PATCH, PUT, DELETE, OPTIONS, HEAD"
+                           , "Access-Control-Allow-Headers" <:> "Authorization, Foo, Bar, Accept, Accept-Language, Content-Language"
+                           , "Access-Control-Max-Age" <:> "86400" ]
+          }
 
-    describe "preflight request" $ do
-      it "replies naively and permissively to preflight request" $ do
-        r <- request methodOptions "/items" preflightHeaders ""
-        liftIO $ do
-          let respHeaders = simpleHeaders r
-          respHeaders `shouldSatisfy` matchHeader
-            "Access-Control-Allow-Origin"
-            "http://example.com"
-          respHeaders `shouldSatisfy` matchHeader
-            "Access-Control-Allow-Credentials"
-            "true"
-          respHeaders `shouldSatisfy` matchHeader
-            "Access-Control-Allow-Methods"
-            "GET, POST, PATCH, PUT, DELETE, OPTIONS, HEAD"
-          respHeaders `shouldSatisfy` matchHeader
-            "Access-Control-Allow-Headers"
-            "Authentication, Foo, Bar, Accept, Accept-Language, Content-Language"
-          respHeaders `shouldSatisfy` matchHeader
-            "Access-Control-Max-Age"
-            "86400"
+    it "exposes necesssary response headers to regular request" $
+      request methodGet "/items"
+          [("Origin", "http://example.com")]
+          ""
+        `shouldRespondWith`
+          ResponseMatcher
+          { matchStatus = 200
+          , matchBody = MatchBody (\_ _ -> Nothing) -- match any body
+          , matchHeaders = [ "Access-Control-Expose-Headers" <:>
+                             "Content-Encoding, Content-Location, Content-Range, Content-Type, \
+                             \Date, Location, Server, Transfer-Encoding, Range-Unit"]
+          }
 
-      it "suppresses body in response" $ do
-        r <- request methodOptions "/" preflightHeaders ""
-        liftIO $ simpleBody r `shouldBe` ""
-
-    describe "regular request" $
-      it "exposes necesssary response headers" $ do
-        r <- request methodGet "/items" [("Origin", "http://example.com")] ""
-        liftIO $ simpleHeaders r `shouldSatisfy` matchHeader
-          "Access-Control-Expose-Headers"
-          "Content-Encoding, Content-Location, Content-Range, Content-Type, \
-            \Date, Location, Server, Transfer-Encoding, Range-Unit"
-
-    describe "postflight request" $
-      it "allows INFO body through even with CORS request headers present" $ do
-        r <- request methodOptions "/items" normalCors ""
-        liftIO $ do
-          simpleHeaders r `shouldSatisfy` matchHeader
-            "Access-Control-Allow-Origin" "\\*"
-          simpleBody r `shouldSatisfy` BL.null
+    it "allows INFO body through even with CORS request headers present to postflight request" $
+      request methodOptions "/items"
+          [ ("Host", "localhost:3000")
+          , ("User-Agent", "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.9; rv:32.0) Gecko/20100101 Firefox/32.0")
+          , ("Origin", "http://localhost:8000")
+          , ("Accept", "text/csv, */*; q=0.01")
+          , ("Accept-Language", "en-US,en;q=0.5")
+          , ("Accept-Encoding", "gzip, deflate")
+          , ("Referer", "http://localhost:8000/")
+          , ("Connection", "keep-alive") ]
+          ""
+        `shouldRespondWith`
+          ""
+          { matchHeaders = [ "Access-Control-Allow-Origin" <:> "*" ] }