{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

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 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 (packageversion, progname, prognameandversion)
import Hledger.Web.Settings (defhost, defport, defbaseurl)

-- cf Hledger.Cli.Version

packageversion :: String
#ifdef VERSION
packageversion :: String
packageversion = VERSION
#else
packageversion = ""
#endif

progname :: String
progname :: String
progname = String
"hledger-web"

prognameandversion :: String
prognameandversion :: String
prognameandversion = String -> String
versionStringForProgname String
progname


webflags :: [Flag RawOpts]
webflags :: [Flag RawOpts]
webflags =
  [ [String] -> (RawOpts -> RawOpts) -> String -> Flag RawOpts
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone
      [String
"serve", String
"server"]
      (String -> RawOpts -> RawOpts
setboolopt String
"serve")
      String
"serve and log requests, don't browse or auto-exit"
  , [String] -> (RawOpts -> RawOpts) -> String -> Flag RawOpts
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone
      [String
"serve-api"]
      (String -> RawOpts -> RawOpts
setboolopt String
"serve-api")
      String
"like --serve, but serve only the JSON web API, without the server-side web UI"
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"cors"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"cors" String
s RawOpts
opts)
      String
"ORIGIN"
      (String
"allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin")
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"socket"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"socket" String
s RawOpts
opts)
      String
"SOCKET"
      String
"use the given socket instead of the given IP and port (implies --serve)"
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"host"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"host" String
s RawOpts
opts)
      String
"IPADDR"
      (String
"listen on this IP address (default: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
defhost String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"port"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"port" String
s RawOpts
opts)
      String
"PORT"
      (String
"listen on this TCP port (default: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
defport String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"base-url"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"base-url" String
s RawOpts
opts)
      String
"BASEURL"
      String
"set the base url (default: http://IPADDR:PORT)"
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"file-url"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"file-url" String
s RawOpts
opts)
      String
"FILEURL"
      String
"set the static files url (default: BASEURL/static)"
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"capabilities"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"capabilities" String
s RawOpts
opts)
      String
"CAP[,CAP..]"
      String
"enable the view, add, and/or manage capabilities (default: view,add)"
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"capabilities-header"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"capabilities-header" String
s RawOpts
opts)
      String
"HTTPHEADER"
      String
"read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)"
  , [String] -> (RawOpts -> RawOpts) -> String -> Flag RawOpts
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone
      [String
"test"]
      (String -> RawOpts -> RawOpts
setboolopt String
"test")
      String
"run hledger-web's tests and exit. hspec test runner args may follow a --, eg: hledger-web --test -- --help"
  ]

webmode :: Mode RawOpts
webmode :: Mode RawOpts
webmode =
  (String
-> RawOpts
-> String
-> Arg RawOpts
-> [Flag RawOpts]
-> Mode RawOpts
forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode
     String
"hledger-web"
     (String -> String -> RawOpts -> RawOpts
setopt String
"command" String
"web" RawOpts
forall a. Default a => a
def)
     String
"start serving the hledger web interface"
     (String -> Arg RawOpts
argsFlag String
"[PATTERNS]")
     [])
  { modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags =
      Group :: forall a. [a] -> [a] -> [(String, [a])] -> Group a
Group
      { groupUnnamed :: [Flag RawOpts]
groupUnnamed = [Flag RawOpts]
webflags
      , groupHidden :: [Flag RawOpts]
groupHidden =
          [Flag RawOpts]
hiddenflags 
          -- ++
          -- [ flagNone
          --     ["binary-filename"]
          --     (setboolopt "binary-filename")
          --     "show the download filename for this executable, and exit"
          -- ]
      , groupNamed :: [(String, [Flag RawOpts])]
groupNamed = [(String, [Flag RawOpts])
generalflagsgroup1]
      }
  , modeHelpSuffix :: [String]
modeHelpSuffix = []
  }

-- hledger-web options, used in hledger-web and above
data WebOpts = WebOpts
  { WebOpts -> Bool
serve_ :: Bool
  , WebOpts -> Bool
serve_api_ :: Bool
  , WebOpts -> Maybe String
cors_ :: Maybe String
  , WebOpts -> String
host_ :: String
  , WebOpts -> Int
port_ :: Int
  , WebOpts -> String
base_url_ :: String
  , WebOpts -> Maybe String
file_url_ :: Maybe String
  , WebOpts -> [Capability]
capabilities_ :: [Capability]
  , WebOpts -> Maybe (CI ByteString)
capabilitiesHeader_ :: Maybe (CI ByteString)
  , WebOpts -> CliOpts
cliopts_ :: CliOpts
  , WebOpts -> Maybe String
socket_ :: Maybe String
  } deriving (Int -> WebOpts -> String -> String
[WebOpts] -> String -> String
WebOpts -> String
(Int -> WebOpts -> String -> String)
-> (WebOpts -> String)
-> ([WebOpts] -> String -> String)
-> Show WebOpts
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [WebOpts] -> String -> String
$cshowList :: [WebOpts] -> String -> String
show :: WebOpts -> String
$cshow :: WebOpts -> String
showsPrec :: Int -> WebOpts -> String -> String
$cshowsPrec :: Int -> WebOpts -> String -> String
Show)

defwebopts :: WebOpts
defwebopts :: WebOpts
defwebopts = WebOpts :: Bool
-> Bool
-> Maybe String
-> String
-> Int
-> String
-> Maybe String
-> [Capability]
-> Maybe (CI ByteString)
-> CliOpts
-> Maybe String
-> WebOpts
WebOpts
  { serve_ :: Bool
serve_              = Bool
False
  , serve_api_ :: Bool
serve_api_          = Bool
False
  , cors_ :: Maybe String
cors_               = Maybe String
forall a. Maybe a
Nothing
  , host_ :: String
host_               = String
""
  , port_ :: Int
port_               = Int
forall a. Default a => a
def
  , base_url_ :: String
base_url_           = String
""
  , file_url_ :: Maybe String
file_url_           = Maybe String
forall a. Maybe a
Nothing
  , capabilities_ :: [Capability]
capabilities_       = [Capability
CapView, Capability
CapAdd]
  , capabilitiesHeader_ :: Maybe (CI ByteString)
capabilitiesHeader_ = Maybe (CI ByteString)
forall a. Maybe a
Nothing
  , cliopts_ :: CliOpts
cliopts_            = CliOpts
forall a. Default a => a
def
  , socket_ :: Maybe String
socket_             = Maybe String
forall a. Maybe a
Nothing
  }

instance Default WebOpts where def :: WebOpts
def = WebOpts
defwebopts

rawOptsToWebOpts :: RawOpts -> IO WebOpts
rawOptsToWebOpts :: RawOpts -> IO WebOpts
rawOptsToWebOpts RawOpts
rawopts =
  WebOpts -> WebOpts
checkWebOpts (WebOpts -> WebOpts) -> IO WebOpts -> IO WebOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    CliOpts
cliopts <- RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts
    let h :: String
h = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defhost (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe String
maybestringopt String
"host" RawOpts
rawopts
        p :: Int
p = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defport (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe Int
maybeposintopt String
"port" RawOpts
rawopts
        b :: String
b =
          String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Int -> String
defbaseurl String
h Int
p) String -> String
stripTrailingSlash (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$
          String -> RawOpts -> Maybe String
maybestringopt String
"base-url" RawOpts
rawopts
        caps' :: [Text]
caps' = Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> [Text]) -> [String] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> RawOpts -> [String]
listofstringopt String
"capabilities" RawOpts
rawopts
        caps :: [Capability]
caps = case (Text -> Either Text Capability)
-> [Text] -> Either Text [Capability]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either Text Capability
capabilityFromText [Text]
caps' of
          Left Text
e -> String -> [Capability]
forall a. String -> a
error' (String
"Unknown capability: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
e)  -- PARTIAL:
          Right [] -> [Capability
CapView, Capability
CapAdd]
          Right [Capability]
xs -> [Capability]
xs
        sock :: Maybe String
sock = String -> String
stripTrailingSlash (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RawOpts -> Maybe String
maybestringopt String
"socket" RawOpts
rawopts
    WebOpts -> IO WebOpts
forall (m :: * -> *) a. Monad m => a -> m a
return
      WebOpts
defwebopts
      { serve_ :: Bool
serve_ = case Maybe String
sock of
          Just String
_ -> Bool
True
          Maybe String
Nothing -> String -> RawOpts -> Bool
boolopt String
"serve" RawOpts
rawopts
      , serve_api_ :: Bool
serve_api_ = String -> RawOpts -> Bool
boolopt String
"serve-api" RawOpts
rawopts
      , cors_ :: Maybe String
cors_ = String -> RawOpts -> Maybe String
maybestringopt String
"cors" RawOpts
rawopts
      , host_ :: String
host_ = String
h
      , port_ :: Int
port_ = Int
p
      , base_url_ :: String
base_url_ = String
b
      , file_url_ :: Maybe String
file_url_ = String -> String
stripTrailingSlash (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RawOpts -> Maybe String
maybestringopt String
"file-url" RawOpts
rawopts
      , capabilities_ :: [Capability]
capabilities_ = [Capability]
caps
      , capabilitiesHeader_ :: Maybe (CI ByteString)
capabilitiesHeader_ = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString)
-> (String -> ByteString) -> String -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BC.pack (String -> CI ByteString) -> Maybe String -> Maybe (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RawOpts -> Maybe String
maybestringopt String
"capabilities-header" RawOpts
rawopts
      , cliopts_ :: CliOpts
cliopts_ = CliOpts
cliopts
      , socket_ :: Maybe String
socket_ = Maybe String
sock
      }
  where
    stripTrailingSlash :: String -> String
stripTrailingSlash = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse -- yesod don't like it

checkWebOpts :: WebOpts -> WebOpts
checkWebOpts :: WebOpts -> WebOpts
checkWebOpts = WebOpts -> WebOpts
forall a. a -> a
id

getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts = do
  [String]
args <- ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> [String]
replaceNumericFlags (IO [String] -> IO [String])
-> ([String] -> IO [String]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> IO [String]
expandArgsAt ([String] -> IO [String]) -> IO [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getArgs
  RawOpts -> IO WebOpts
rawOptsToWebOpts (RawOpts -> IO WebOpts)
-> (Either String RawOpts -> RawOpts)
-> Either String RawOpts
-> IO WebOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> RawOpts)
-> (RawOpts -> RawOpts) -> Either String RawOpts -> RawOpts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> RawOpts
forall a. String -> a
usageError RawOpts -> RawOpts
forall a. a -> a
id (Either String RawOpts -> IO WebOpts)
-> Either String RawOpts -> IO WebOpts
forall a b. (a -> b) -> a -> b
$ Mode RawOpts -> [String] -> Either String RawOpts
forall a. Mode a -> [String] -> Either String a
process Mode RawOpts
webmode [String]
args

data Capability
  = CapView
  | CapAdd
  | CapManage
  deriving (Capability -> Capability -> Bool
(Capability -> Capability -> Bool)
-> (Capability -> Capability -> Bool) -> Eq Capability
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Capability -> Capability -> Bool
$c/= :: Capability -> Capability -> Bool
== :: Capability -> Capability -> Bool
$c== :: Capability -> Capability -> Bool
Eq, Eq Capability
Eq Capability
-> (Capability -> Capability -> Ordering)
-> (Capability -> Capability -> Bool)
-> (Capability -> Capability -> Bool)
-> (Capability -> Capability -> Bool)
-> (Capability -> Capability -> Bool)
-> (Capability -> Capability -> Capability)
-> (Capability -> Capability -> Capability)
-> Ord Capability
Capability -> Capability -> Bool
Capability -> Capability -> Ordering
Capability -> Capability -> Capability
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Capability -> Capability -> Capability
$cmin :: Capability -> Capability -> Capability
max :: Capability -> Capability -> Capability
$cmax :: Capability -> Capability -> Capability
>= :: Capability -> Capability -> Bool
$c>= :: Capability -> Capability -> Bool
> :: Capability -> Capability -> Bool
$c> :: Capability -> Capability -> Bool
<= :: Capability -> Capability -> Bool
$c<= :: Capability -> Capability -> Bool
< :: Capability -> Capability -> Bool
$c< :: Capability -> Capability -> Bool
compare :: Capability -> Capability -> Ordering
$ccompare :: Capability -> Capability -> Ordering
$cp1Ord :: Eq Capability
Ord, Capability
Capability -> Capability -> Bounded Capability
forall a. a -> a -> Bounded a
maxBound :: Capability
$cmaxBound :: Capability
minBound :: Capability
$cminBound :: Capability
Bounded, Int -> Capability
Capability -> Int
Capability -> [Capability]
Capability -> Capability
Capability -> Capability -> [Capability]
Capability -> Capability -> Capability -> [Capability]
(Capability -> Capability)
-> (Capability -> Capability)
-> (Int -> Capability)
-> (Capability -> Int)
-> (Capability -> [Capability])
-> (Capability -> Capability -> [Capability])
-> (Capability -> Capability -> [Capability])
-> (Capability -> Capability -> Capability -> [Capability])
-> Enum Capability
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Capability -> Capability -> Capability -> [Capability]
$cenumFromThenTo :: Capability -> Capability -> Capability -> [Capability]
enumFromTo :: Capability -> Capability -> [Capability]
$cenumFromTo :: Capability -> Capability -> [Capability]
enumFromThen :: Capability -> Capability -> [Capability]
$cenumFromThen :: Capability -> Capability -> [Capability]
enumFrom :: Capability -> [Capability]
$cenumFrom :: Capability -> [Capability]
fromEnum :: Capability -> Int
$cfromEnum :: Capability -> Int
toEnum :: Int -> Capability
$ctoEnum :: Int -> Capability
pred :: Capability -> Capability
$cpred :: Capability -> Capability
succ :: Capability -> Capability
$csucc :: Capability -> Capability
Enum, Int -> Capability -> String -> String
[Capability] -> String -> String
Capability -> String
(Int -> Capability -> String -> String)
-> (Capability -> String)
-> ([Capability] -> String -> String)
-> Show Capability
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Capability] -> String -> String
$cshowList :: [Capability] -> String -> String
show :: Capability -> String
$cshow :: Capability -> String
showsPrec :: Int -> Capability -> String -> String
$cshowsPrec :: Int -> Capability -> String -> String
Show)

capabilityFromText :: Text -> Either Text Capability
capabilityFromText :: Text -> Either Text Capability
capabilityFromText Text
"view" = Capability -> Either Text Capability
forall a b. b -> Either a b
Right Capability
CapView
capabilityFromText Text
"add" = Capability -> Either Text Capability
forall a b. b -> Either a b
Right Capability
CapAdd
capabilityFromText Text
"manage" = Capability -> Either Text Capability
forall a b. b -> Either a b
Right Capability
CapManage
capabilityFromText Text
x = Text -> Either Text Capability
forall a b. a -> Either a b
Left Text
x

capabilityFromBS :: ByteString -> Either ByteString Capability
capabilityFromBS :: ByteString -> Either ByteString Capability
capabilityFromBS ByteString
"view" = Capability -> Either ByteString Capability
forall a b. b -> Either a b
Right Capability
CapView
capabilityFromBS ByteString
"add" = Capability -> Either ByteString Capability
forall a b. b -> Either a b
Right Capability
CapAdd
capabilityFromBS ByteString
"manage" = Capability -> Either ByteString Capability
forall a b. b -> Either a b
Right Capability
CapManage
capabilityFromBS ByteString
x = ByteString -> Either ByteString Capability
forall a b. a -> Either a b
Left ByteString
x

simplePolicyWithOrigin :: Origin -> CorsResourcePolicy
simplePolicyWithOrigin :: ByteString -> CorsResourcePolicy
simplePolicyWithOrigin ByteString
origin =
    CorsResourcePolicy
simpleCorsResourcePolicy { corsOrigins :: Maybe ([ByteString], Bool)
corsOrigins = ([ByteString], Bool) -> Maybe ([ByteString], Bool)
forall a. a -> Maybe a
Just ([ByteString
origin], Bool
False) }


corsPolicyFromString :: String -> WAI.Middleware
corsPolicyFromString :: String -> Middleware
corsPolicyFromString String
origin =
  let
    policy :: CorsResourcePolicy
policy = case String
origin of
        String
"*" -> CorsResourcePolicy
simpleCorsResourcePolicy
        String
url -> ByteString -> CorsResourcePolicy
simplePolicyWithOrigin (ByteString -> CorsResourcePolicy)
-> ByteString -> CorsResourcePolicy
forall a b. (a -> b) -> a -> b
$ String -> ByteString
fromString String
url
  in
    (Request -> Maybe CorsResourcePolicy) -> Middleware
cors (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. a -> b -> a
const (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy)
-> Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. (a -> b) -> a -> b
$ CorsResourcePolicy -> Maybe CorsResourcePolicy
forall a. a -> Maybe a
Just CorsResourcePolicy
policy)

corsPolicy :: WebOpts -> (Application -> Application)
corsPolicy :: WebOpts -> Middleware
corsPolicy WebOpts
opts =
  Middleware -> (String -> Middleware) -> Maybe String -> Middleware
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Middleware
forall a. a -> a
id String -> Middleware
corsPolicyFromString (Maybe String -> Middleware) -> Maybe String -> Middleware
forall a b. (a -> b) -> a -> b
$ WebOpts -> Maybe String
cors_ WebOpts
opts