web: Modify the --cors option to require a specific origin

- Modified the cors option to require a String
- Moved the logic to build the cors policy to WebOptions.hs
- Specify the --cors "*" example in the cors option help
- Added utf8-string dependency to convert a String into a ByteString

hledger-web/Hledger/Web/Application.hs

@@ -10,7 +10,6 @@ module Hledger.Web.Application
 
 import Data.IORef (newIORef, writeIORef)
 import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
-import Network.Wai.Middleware.Cors
 import Network.HTTP.Client (defaultManagerSettings)
 import Network.HTTP.Conduit (newManager)
 import Yesod.Default.Config
@@ -24,7 +23,7 @@ import Hledger.Web.Handler.UploadR
 import Hledger.Web.Handler.JournalR
 import Hledger.Web.Handler.RegisterR
 import Hledger.Web.Import
-import Hledger.Web.WebOptions (WebOpts(serve_,serve_api_,cors_))
+import Hledger.Web.WebOptions (WebOpts(serve_,serve_api_), corsPolicy)
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -39,13 +38,11 @@ makeApplication :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Applic
 makeApplication opts' j' conf' = do
     foundation <- makeFoundation conf' opts'
     writeIORef (appJournal foundation) j'
-    (logWare . corsWare) <$> toWaiApp foundation
+    (logWare . (corsPolicy opts')) <$> toWaiApp foundation
   where
     logWare | development  = logStdoutDev
             | serve_ opts' || serve_api_ opts' = logStdout
             | otherwise    = id
-    corsWare | cors_ opts' = simpleCors
-             | otherwise = id
 
 makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App
 makeFoundation conf opts' = do

hledger-web/Hledger/Web/WebOptions.hs

@@ -4,6 +4,7 @@ module Hledger.Web.WebOptions where
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BC
+import Data.ByteString.UTF8 (fromString)
 import Data.CaseInsensitive (CI, mk)
 import Control.Monad (join)
 import Data.Default (Default(def))
@@ -11,6 +12,8 @@ import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Data.Text (Text)
 import System.Environment (getArgs)
+import Network.Wai as WAI
+import Network.Wai.Middleware.Cors
 
 import Hledger.Cli hiding (progname, version)
 import Hledger.Web.Settings (defhost, defport, defbaseurl)
@@ -35,10 +38,11 @@ webflags =
       ["serve-api"]
       (setboolopt "serve-api")
       "like --serve, but serve only the JSON web API, without the server-side web UI"
-  , flagNone
+  , flagReq
       ["cors"]
-      (setboolopt "cors")
+      (\s opts -> Right $ setopt "cors" s opts)
-      ("allow cross-origin requests, setting the Access-Control-Allow-Origin HTTP header to *")
+      "ORIGIN"
+      ("allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin")
   , flagReq
       ["host"]
       (\s opts -> Right $ setopt "host" s opts)
@@ -98,7 +102,7 @@ webmode =
 data WebOpts = WebOpts
   { serve_ :: Bool
   , serve_api_ :: Bool
-  , cors_ :: Bool
+  , cors_ :: Maybe String
   , host_ :: String
   , port_ :: Int
   , base_url_ :: String
@@ -109,7 +113,7 @@ data WebOpts = WebOpts
   } deriving (Show)
 
 defwebopts :: WebOpts
-defwebopts = WebOpts def def def def def def def [CapView, CapAdd] Nothing def
+defwebopts = WebOpts def def Nothing def def def def [CapView, CapAdd] Nothing def
 
 instance Default WebOpts where def = defwebopts
 
@@ -131,7 +135,7 @@ rawOptsToWebOpts rawopts =
       defwebopts
       { serve_ = boolopt "serve" rawopts
       , serve_api_ = boolopt "serve-api" rawopts
-      , cors_ = boolopt "cors" rawopts
+      , cors_ = maybestringopt "cors" rawopts
       , host_ = h
       , port_ = p
       , base_url_ = b
@@ -172,3 +176,21 @@ capabilityFromBS "view" = Right CapView
 capabilityFromBS "add" = Right CapAdd
 capabilityFromBS "manage" = Right CapManage
 capabilityFromBS x = Left x
+
+simplePolicyWithOrigin :: Origin -> CorsResourcePolicy
+simplePolicyWithOrigin origin =
+    simpleCorsResourcePolicy { corsOrigins = Just ([origin], False) }
+
+
+corsPolicyFromString :: String -> WAI.Middleware
+corsPolicyFromString origin =
+  let
+    policy = case origin of
+        "*" -> simpleCorsResourcePolicy
+        url -> simplePolicyWithOrigin $ fromString url
+  in
+    cors (const $ Just policy)
+
+corsPolicy :: WebOpts -> (Application -> Application)
+corsPolicy opts =
+  maybe id corsPolicyFromString $ cors_ opts

hledger-web/hledger-web.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: bb22226fe2d7562c91dc7dabb7767a786db0ea4441bb79b9016c414c0d5edf59
+-- hash: 4595326c17d463479b0d80c19012ffd367ef2cedbbdee610e8792fd88d4e4c4c
 
 name:           hledger-web
 version:        1.15.99
@@ -183,6 +183,7 @@ library
     , text >=1.2
     , time >=1.5
     , transformers
+    , utf8-string
     , wai
     , wai-cors
     , wai-extra

hledger-web/package.yaml

@@ -129,6 +129,7 @@ library:
   - text >=1.2
   - time >=1.5
   - transformers
+  - utf8-string
   - wai
   - wai-extra
   - wai-handler-launch >=1.3