Skip to content
Permalink
Browse files

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
  • Loading branch information...
agarciamontoro authored and simonmichael committed Oct 7, 2019
1 parent e96dfe8 commit 4efd0242da31310bc5fc7b6d9640ac38d7cbe27f
@@ -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
@@ -4,13 +4,16 @@ 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))
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")
("allow cross-origin requests, setting the Access-Control-Allow-Origin HTTP header to *")
(\s opts -> Right $ setopt "cors" s opts)
"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
@@ -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
@@ -129,6 +129,7 @@ library:
- text >=1.2
- time >=1.5
- transformers
- utf8-string
- wai
- wai-extra
- wai-handler-launch >=1.3

0 comments on commit 4efd024

Please sign in to comment.
You can’t perform that action at this time.