Rudimentary cors feature spec

test/Feature/CorsSpec.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Feature.CorsSpec where
+
+-- {{{ Imports
+import Test.Hspec
+import Test.Hspec.Wai
+import Network.Wai.Test (SResponse(simpleHeaders))
+
+import SpecHelper
+
+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"

test/SpecHelper.hs

@@ -14,8 +14,9 @@ import Data.CaseInsensitive (CI(..))
 import Text.Regex.TDFA ((=~))
 import qualified Data.HashMap.Strict as Hash
 import qualified Data.ByteString.Char8 as BS
+import Network.Wai.Middleware.Cors (cors)
 
-import Dbapi (app, AppConfig(..))
+import Dbapi (app, corsPolicy, AppConfig(..))
 
 cfg :: AppConfig
 cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "test/test.crt" "test/test.key" "dbapi_anonymous"
@@ -40,7 +41,7 @@ dbWithSchema action = withDatabaseConnection $ \c -> do
 appWithFixture :: ActionWith Application -> IO ()
 appWithFixture action = withDatabaseConnection $ \c -> do
   runRaw c "begin;"
-  action $ app c "dbapi_anonymous"
+  action $ cors corsPolicy $ app c "dbapi_anonymous"
   rollback c
 
 rangeHdrs :: ByteRange -> [Header]