first pass at CORS handling.

dbapi.cabal

@@ -16,7 +16,7 @@ executable dbapi
   build-depends:       base >=4.6 && <5
                      , HDBC, HDBC-postgresql
                      , warp, wai >= 3.0.1 && < 3.0.2
-                     , wai-extra
+                     , wai-extra, wai-cors
                      , HTTP, convertible
                      , case-insensitive
                      , http-types, scientific, time
@@ -51,7 +51,7 @@ Test-Suite spec
                      , warp, wai >= 3.0.1 && < 3.0.2
                      , HTTP, convertible
                      , case-insensitive
-                     , wai-extra, containers
+                     , wai-extra, wai-cors, containers
                      , http-types, scientific, time
                      , bytestring, aeson, network
                      , text, optparse-applicative

src/Main.hs

@@ -7,11 +7,16 @@ 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)
 
 -- }}}
 
@@ -28,6 +33,24 @@ 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"] ["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)
@@ -39,7 +62,7 @@ main = do
 
   Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
   conn <- connectPostgreSQL' dburi
-  runTLS tls settings $ gzip def $ app conn (cs $ configAnonRole conf)
+  runTLS tls settings $ gzip def $ cors corsPolicy $ app conn (cs $ configAnonRole conf)
 
   where
     describe = progDesc "create a REST API to an existing Postgres database"