Allow browsers to load table OPTIONS after preflight

Fixes #51

src/Dbapi.hs

@@ -96,7 +96,7 @@ app conn anonymous req respond = do
           responseLBS status200 [jsonContentType] <$> printTables ver conn
 
         ([table], "OPTIONS") ->
-          responseLBS status200 [jsonContentType] <$>
+          responseLBS status200 [jsonContentType, allOrigins] <$>
             printColumns ver (cs table) conn
 
         ([table], "GET") ->
@@ -165,6 +165,7 @@ app conn anonymous req respond = do
     ver    = fromMaybe "1" $ requestedVersion hdrs
     range  = requestedRange hdrs
     cRange = requestedContentRange hdrs
+    allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
 
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing
@@ -174,8 +175,8 @@ defaultCorsPolicy =  CorsResourcePolicy Nothing
 corsPolicy :: Request -> Maybe CorsResourcePolicy
 corsPolicy req = case lookup "origin" headers of
   Just origin -> Just defaultCorsPolicy {
-      corsOrigins = Just ([origin], True),
+      corsOrigins = Just ([origin], True)
-      corsRequestHeaders = "Authentication":accHeaders
+    , corsRequestHeaders = "Authentication":accHeaders
     }
   Nothing -> Nothing
   where

test/Feature/CorsSpec.hs

@@ -5,7 +5,8 @@ module Feature.CorsSpec where
 -- {{{ Imports
 import Test.Hspec
 import Test.Hspec.Wai
-import Network.Wai.Test (SResponse(simpleHeaders))
+import Network.Wai.Test (SResponse(simpleHeaders, simpleBody))
+import qualified Data.ByteString.Lazy as BL
 
 import SpecHelper
 
@@ -14,29 +15,51 @@ import Network.HTTP.Types
 
 spec :: Spec
 spec = around appWithFixture $
-  describe "CORS" $
+  describe "CORS" $ do
-    it "replies naively and permissively to preflight request" $ do
+    let preflightHeaders = [
-      r <- request methodOptions "/"
+          ("Accept", "*/*"),
-        [
+          ("Origin", "http://example.com"),
-          ("Accept", "*/*")
+          ("Access-Control-Request-Method", "POST"),
-        , ("Origin", "http://example.com")
+          ("Access-Control-Request-Headers", "Foo,Bar") ]
-        , ("Access-Control-Request-Method", "POST")
+    let normalCors = [
-        , ("Access-Control-Request-Headers", "Foo,Bar")
+          ("Host", "localhost:3000"),
-        ] ""
+          ("User-Agent", "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.9; rv:32.0) Gecko/20100101 Firefox/32.0"),
-      liftIO $ do
+          ("Origin", "http://localhost:8000"),
-        let respHeaders = simpleHeaders r
+          ("Accept", "text/plain, */*; q=0.01"),
-        respHeaders `shouldSatisfy` matchHeader
+          ("Accept-Language", "en-US,en;q=0.5"),
-          "Access-Control-Allow-Origin"
+          ("Accept-Encoding", "gzip, deflate"),
-          "http://example.com"
+          ("Referer", "http://localhost:8000/"),
-        respHeaders `shouldSatisfy` matchHeader
+          ("Connection", "keep-alive") ]
-          "Access-Control-Allow-Credentials"
+
-          "true"
+    describe "preflight request" $ do
-        respHeaders `shouldSatisfy` matchHeader
+      it "replies naively and permissively to preflight request" $ do
-          "Access-Control-Allow-Methods"
+        r <- request methodOptions "/items" preflightHeaders ""
-          "GET, POST, PUT, PATCH, DELETE, OPTIONS, HEAD"
+        liftIO $ do
-        respHeaders `shouldSatisfy` matchHeader
+          let respHeaders = simpleHeaders r
-          "Access-Control-Allow-Headers"
+          respHeaders `shouldSatisfy` matchHeader
-          "Authentication, Foo, Bar, Accept, Accept-Language, Content-Language"
+            "Access-Control-Allow-Origin"
-        respHeaders `shouldSatisfy` matchHeader
+            "http://example.com"
-          "Access-Control-Max-Age"
+          respHeaders `shouldSatisfy` matchHeader
-          "86400"
+            "Access-Control-Allow-Credentials"
+            "true"
+          respHeaders `shouldSatisfy` matchHeader
+            "Access-Control-Allow-Methods"
+            "GET, POST, PUT, PATCH, 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 "suppresses body in response" $ do
+        r <- request methodOptions "/" preflightHeaders ""
+        liftIO $ simpleBody r `shouldBe` ""
+
+    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` not . BL.null