From 8fbe3839a6d770fa7dcc59f056351a5c0e26acbb Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Tue, 7 Oct 2014 14:55:11 -0700
Subject: [PATCH] Allow browsers to load table OPTIONS after preflight

Fixes #51
---
 src/Dbapi.hs             |  7 ++--
 test/Feature/CorsSpec.hs | 77 ++++++++++++++++++++++++++--------------
 2 files changed, 54 insertions(+), 30 deletions(-)

diff --git a/src/Dbapi.hs b/src/Dbapi.hs
index a6eea6c2a..d6e25bc1d 100644
--- a/src/Dbapi.hs
+++ b/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),
-      corsRequestHeaders = "Authentication":accHeaders
+      corsOrigins = Just ([origin], True)
+    , corsRequestHeaders = "Authentication":accHeaders
     }
   Nothing -> Nothing
   where
diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs
index 52d64d950..29e9bed44 100644
--- a/test/Feature/CorsSpec.hs
+++ b/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" $
-    it "replies naively and permissively to preflight request" $ do
-      r <- request methodOptions "/"
-        [
-          ("Accept", "*/*")
-        , ("Origin", "http://example.com")
-        , ("Access-Control-Request-Method", "POST")
-        , ("Access-Control-Request-Headers", "Foo,Bar")
-        ] ""
-      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, 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"
+  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/plain, */*; q=0.01"),
+          ("Accept-Language", "en-US,en;q=0.5"),
+          ("Accept-Encoding", "gzip, deflate"),
+          ("Referer", "http://localhost:8000/"),
+          ("Connection", "keep-alive") ]
+
+    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, 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