{-# 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 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)

progname, version :: String
progname :: String
progname = String
"hledger-web"
#ifdef VERSION
version :: String
version = VERSION
#else
version = ""
#endif
prognameandversion :: String
prognameandversion :: String
prognameandversion = String
progname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
version :: String

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 [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++
          [ [String] -> (RawOpts -> RawOpts) -> String -> Flag RawOpts
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone
              [String
"binary-filename"]
              (String -> RawOpts -> RawOpts
setboolopt String
"binary-filename")
              String
"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]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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