Rudimentary cors feature spec

src/Dbapi.hs

@@ -18,6 +18,7 @@ import Data.Map (intersection, fromList, toList, Map)
 import Data.List (sort)
 import qualified Data.Set as S
 import Data.Convertible.Base (convert)
+import Data.Text (strip)
 
 import Network.HTTP.Types.Status
 import Network.HTTP.Types.Header
@@ -27,9 +28,11 @@ import Network.HTTP.Base (urlEncodeVars)
 
 import Network.Wai
 import Network.Wai.Internal
+import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
 
 import qualified Data.ByteString.Char8 as BS
 import Data.String.Conversions (cs)
+import qualified Data.CaseInsensitive as CI
 
 import Database.HDBC.PostgreSQL (Connection)
 import Database.HDBC.Types (SqlError, seErrorMsg)
@@ -163,6 +166,25 @@ app conn anonymous req respond = do
     range  = requestedRange hdrs
     cRange = requestedContentRange hdrs
 
+defaultCorsPolicy :: CorsResourcePolicy
+defaultCorsPolicy =  CorsResourcePolicy Nothing
+  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
+  (Just $ 60*60*24) False False True
+
+corsPolicy :: Request -> Maybe CorsResourcePolicy
+corsPolicy req = case lookup "origin" headers of
+  Just origin -> Just defaultCorsPolicy {
+      corsOrigins = Just ([origin], True),
+      corsRequestHeaders = "Authentication":accHeaders
+    }
+  Nothing -> Nothing
+  where
+    headers = requestHeaders req
+    accHeaders = case lookup "access-control-request-headers" headers of
+      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
+      Nothing -> []
+
+
 respondWithRangedResult :: RangedResult -> Response
 respondWithRangedResult rr =
   responseLBS status [

src/Main.hs

@@ -7,16 +7,12 @@ import Dbapi
 import Network.Wai.Handler.Warp hiding (Connection)
 import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
-import qualified Data.CaseInsensitive as CI
-import Data.Text (strip);
-import qualified Data.ByteString.Char8 as BS
 
 import Control.Applicative
 import Options.Applicative hiding (columns)
-import Network.Wai (Request, requestHeaders)
 import Network.Wai.Handler.WarpTLS (tlsSettings, runTLS)
 import Network.Wai.Middleware.Gzip (gzip, def)
-import Network.Wai.Middleware.Cors (CorsResourcePolicy(..), cors)
+import Network.Wai.Middleware.Cors (cors)
 
 -- }}}
 
@@ -33,24 +29,6 @@ argParser = AppConfig
   <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
     <> help "postgres role to use for non-authenticated requests")
 
-defaultCorsPolicy :: CorsResourcePolicy
-defaultCorsPolicy =  CorsResourcePolicy Nothing
-  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
-  (Just $ 60*60*24) False False True
-
-corsPolicy :: Request -> Maybe CorsResourcePolicy
-corsPolicy req = case lookup "origin" headers of
-  Just origin -> Just defaultCorsPolicy {
-      corsOrigins = Just ([origin], True),
-      corsRequestHeaders = "Authentication":accHeaders
-    }
-  Nothing -> Nothing
-  where
-    headers = requestHeaders req
-    accHeaders = case lookup "access-control-request-headers" headers of
-      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
-      Nothing -> []
-
 main :: IO ()
 main = do
   conf <- execParser (info (helper <*> argParser) describe)

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]