{-# 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 :: PackageVersion
packageversion :: PackageVersion
packageversion =
#ifdef VERSION
  VERSION
#else
  ""
#endif

progname :: ProgramName
progname :: PackageVersion
progname = PackageVersion
"hledger-web"

prognameandversion :: VersionString
prognameandversion :: PackageVersion
prognameandversion = PackageVersion -> PackageVersion -> PackageVersion
versionString PackageVersion
progname PackageVersion
packageversion


webflags :: [Flag RawOpts]
webflags :: [Flag RawOpts]
webflags =
  [ [PackageVersion]
-> (RawOpts -> RawOpts) -> PackageVersion -> Flag RawOpts
forall a. [PackageVersion] -> (a -> a) -> PackageVersion -> Flag a
flagNone
      [PackageVersion
"serve", PackageVersion
"server"]
      (PackageVersion -> RawOpts -> RawOpts
setboolopt PackageVersion
"serve")
      PackageVersion
"serve and log requests, don't browse or auto-exit"
  , [PackageVersion]
-> (RawOpts -> RawOpts) -> PackageVersion -> Flag RawOpts
forall a. [PackageVersion] -> (a -> a) -> PackageVersion -> Flag a
flagNone
      [PackageVersion
"serve-api"]
      (PackageVersion -> RawOpts -> RawOpts
setboolopt PackageVersion
"serve-api")
      PackageVersion
"like --serve, but serve only the JSON web API, without the server-side web UI"
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"cors"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"cors" PackageVersion
s RawOpts
opts)
      PackageVersion
"ORIGIN"
      (PackageVersion
"allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin")
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"socket"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"socket" PackageVersion
s RawOpts
opts)
      PackageVersion
"SOCKET"
      PackageVersion
"use the given socket instead of the given IP and port (implies --serve)"
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"host"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"host" PackageVersion
s RawOpts
opts)
      PackageVersion
"IPADDR"
      (PackageVersion
"listen on this IP address (default: " PackageVersion -> PackageVersion -> PackageVersion
forall a. [a] -> [a] -> [a]
++ PackageVersion
defhost PackageVersion -> PackageVersion -> PackageVersion
forall a. [a] -> [a] -> [a]
++ PackageVersion
")")
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"port"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"port" PackageVersion
s RawOpts
opts)
      PackageVersion
"PORT"
      (PackageVersion
"listen on this TCP port (default: " PackageVersion -> PackageVersion -> PackageVersion
forall a. [a] -> [a] -> [a]
++ Int -> PackageVersion
forall a. Show a => a -> PackageVersion
show Int
defport PackageVersion -> PackageVersion -> PackageVersion
forall a. [a] -> [a] -> [a]
++ PackageVersion
")")
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"base-url"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"base-url" PackageVersion
s RawOpts
opts)
      PackageVersion
"BASEURL"
      PackageVersion
"set the base url (default: http://IPADDR:PORT)"
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"file-url"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"file-url" PackageVersion
s RawOpts
opts)
      PackageVersion
"FILEURL"
      PackageVersion
"set the static files url (default: BASEURL/static)"
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"capabilities"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"capabilities" PackageVersion
s RawOpts
opts)
      PackageVersion
"CAP[,CAP..]"
      PackageVersion
"enable the view, add, and/or manage capabilities (default: view,add)"
  , [PackageVersion]
-> Update RawOpts
-> PackageVersion
-> PackageVersion
-> Flag RawOpts
forall a.
[PackageVersion]
-> Update a -> PackageVersion -> PackageVersion -> Flag a
flagReq
      [PackageVersion
"capabilities-header"]
      (\PackageVersion
s RawOpts
opts -> RawOpts -> Either PackageVersion RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersion RawOpts)
-> RawOpts -> Either PackageVersion RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"capabilities-header" PackageVersion
s RawOpts
opts)
      PackageVersion
"HTTPHEADER"
      PackageVersion
"read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)"
  , [PackageVersion]
-> (RawOpts -> RawOpts) -> PackageVersion -> Flag RawOpts
forall a. [PackageVersion] -> (a -> a) -> PackageVersion -> Flag a
flagNone
      [PackageVersion
"test"]
      (PackageVersion -> RawOpts -> RawOpts
setboolopt PackageVersion
"test")
      PackageVersion
"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 =
  (PackageVersion
-> RawOpts
-> PackageVersion
-> Arg RawOpts
-> [Flag RawOpts]
-> Mode RawOpts
forall a.
PackageVersion
-> a -> PackageVersion -> Arg a -> [Flag a] -> Mode a
mode
     PackageVersion
"hledger-web"
     (PackageVersion -> PackageVersion -> RawOpts -> RawOpts
setopt PackageVersion
"command" PackageVersion
"web" RawOpts
forall a. Default a => a
def)
     PackageVersion
"start serving the hledger web interface"
     (PackageVersion -> Arg RawOpts
argsFlag PackageVersion
"[PATTERNS]")
     [])
  { modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags =
      Group :: forall a. [a] -> [a] -> [(PackageVersion, [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 :: [(PackageVersion, [Flag RawOpts])]
groupNamed = [(PackageVersion, [Flag RawOpts])
generalflagsgroup1]
      }
  , modeHelpSuffix :: [PackageVersion]
modeHelpSuffix = []
  }

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

defwebopts :: WebOpts
defwebopts :: WebOpts
defwebopts = WebOpts :: Bool
-> Bool
-> Maybe PackageVersion
-> PackageVersion
-> Int
-> PackageVersion
-> Maybe PackageVersion
-> [Capability]
-> Maybe (CI ByteString)
-> CliOpts
-> Maybe PackageVersion
-> WebOpts
WebOpts
  { serve_ :: Bool
serve_              = Bool
False
  , serve_api_ :: Bool
serve_api_          = Bool
False
  , cors_ :: Maybe PackageVersion
cors_               = Maybe PackageVersion
forall a. Maybe a
Nothing
  , host_ :: PackageVersion
host_               = PackageVersion
""
  , port_ :: Int
port_               = Int
forall a. Default a => a
def
  , base_url_ :: PackageVersion
base_url_           = PackageVersion
""
  , file_url_ :: Maybe PackageVersion
file_url_           = Maybe PackageVersion
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 PackageVersion
socket_             = Maybe PackageVersion
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 :: PackageVersion
h = PackageVersion -> Maybe PackageVersion -> PackageVersion
forall a. a -> Maybe a -> a
fromMaybe PackageVersion
defhost (Maybe PackageVersion -> PackageVersion)
-> Maybe PackageVersion -> PackageVersion
forall a b. (a -> b) -> a -> b
$ PackageVersion -> RawOpts -> Maybe PackageVersion
maybestringopt PackageVersion
"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
$ PackageVersion -> RawOpts -> Maybe Int
maybeposintopt PackageVersion
"port" RawOpts
rawopts
        b :: PackageVersion
b =
          PackageVersion
-> (PackageVersion -> PackageVersion)
-> Maybe PackageVersion
-> PackageVersion
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageVersion -> Int -> PackageVersion
defbaseurl PackageVersion
h Int
p) PackageVersion -> PackageVersion
stripTrailingSlash (Maybe PackageVersion -> PackageVersion)
-> Maybe PackageVersion -> PackageVersion
forall a b. (a -> b) -> a -> b
$
          PackageVersion -> RawOpts -> Maybe PackageVersion
maybestringopt PackageVersion
"base-url" RawOpts
rawopts
        caps' :: [Text]
caps' = Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text])
-> (PackageVersion -> Text) -> PackageVersion -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageVersion -> Text
T.pack (PackageVersion -> [Text]) -> [PackageVersion] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PackageVersion -> RawOpts -> [PackageVersion]
listofstringopt PackageVersion
"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 -> PackageVersion -> [Capability]
forall a. PackageVersion -> a
error' (PackageVersion
"Unknown capability: " PackageVersion -> PackageVersion -> PackageVersion
forall a. [a] -> [a] -> [a]
++ Text -> PackageVersion
T.unpack Text
e)  -- PARTIAL:
          Right [] -> [Capability
CapView, Capability
CapAdd]
          Right [Capability]
xs -> [Capability]
xs
        sock :: Maybe PackageVersion
sock = PackageVersion -> PackageVersion
stripTrailingSlash (PackageVersion -> PackageVersion)
-> Maybe PackageVersion -> Maybe PackageVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageVersion -> RawOpts -> Maybe PackageVersion
maybestringopt PackageVersion
"socket" RawOpts
rawopts
    WebOpts -> IO WebOpts
forall (m :: * -> *) a. Monad m => a -> m a
return
      WebOpts
defwebopts
      { serve_ :: Bool
serve_ = case Maybe PackageVersion
sock of
          Just PackageVersion
_ -> Bool
True
          Maybe PackageVersion
Nothing -> PackageVersion -> RawOpts -> Bool
boolopt PackageVersion
"serve" RawOpts
rawopts
      , serve_api_ :: Bool
serve_api_ = PackageVersion -> RawOpts -> Bool
boolopt PackageVersion
"serve-api" RawOpts
rawopts
      , cors_ :: Maybe PackageVersion
cors_ = PackageVersion -> RawOpts -> Maybe PackageVersion
maybestringopt PackageVersion
"cors" RawOpts
rawopts
      , host_ :: PackageVersion
host_ = PackageVersion
h
      , port_ :: Int
port_ = Int
p
      , base_url_ :: PackageVersion
base_url_ = PackageVersion
b
      , file_url_ :: Maybe PackageVersion
file_url_ = PackageVersion -> PackageVersion
stripTrailingSlash (PackageVersion -> PackageVersion)
-> Maybe PackageVersion -> Maybe PackageVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageVersion -> RawOpts -> Maybe PackageVersion
maybestringopt PackageVersion
"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)
-> (PackageVersion -> ByteString)
-> PackageVersion
-> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageVersion -> ByteString
BC.pack (PackageVersion -> CI ByteString)
-> Maybe PackageVersion -> Maybe (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageVersion -> RawOpts -> Maybe PackageVersion
maybestringopt PackageVersion
"capabilities-header" RawOpts
rawopts
      , cliopts_ :: CliOpts
cliopts_ = CliOpts
cliopts
      , socket_ :: Maybe PackageVersion
socket_ = Maybe PackageVersion
sock
      }
  where
    stripTrailingSlash :: PackageVersion -> PackageVersion
stripTrailingSlash = PackageVersion -> PackageVersion
forall a. [a] -> [a]
reverse (PackageVersion -> PackageVersion)
-> (PackageVersion -> PackageVersion)
-> PackageVersion
-> PackageVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> PackageVersion -> PackageVersion
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (PackageVersion -> PackageVersion)
-> (PackageVersion -> PackageVersion)
-> PackageVersion
-> PackageVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageVersion -> PackageVersion
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
  [PackageVersion]
args <- ([PackageVersion] -> [PackageVersion])
-> IO [PackageVersion] -> IO [PackageVersion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PackageVersion] -> [PackageVersion]
replaceNumericFlags (IO [PackageVersion] -> IO [PackageVersion])
-> ([PackageVersion] -> IO [PackageVersion])
-> [PackageVersion]
-> IO [PackageVersion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageVersion] -> IO [PackageVersion]
expandArgsAt ([PackageVersion] -> IO [PackageVersion])
-> IO [PackageVersion] -> IO [PackageVersion]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [PackageVersion]
getArgs
  RawOpts -> IO WebOpts
rawOptsToWebOpts (RawOpts -> IO WebOpts)
-> (Either PackageVersion RawOpts -> RawOpts)
-> Either PackageVersion RawOpts
-> IO WebOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageVersion -> RawOpts)
-> (RawOpts -> RawOpts) -> Either PackageVersion RawOpts -> RawOpts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PackageVersion -> RawOpts
forall a. PackageVersion -> a
usageError RawOpts -> RawOpts
forall a. a -> a
id (Either PackageVersion RawOpts -> IO WebOpts)
-> Either PackageVersion RawOpts -> IO WebOpts
forall a b. (a -> b) -> a -> b
$ Mode RawOpts -> [PackageVersion] -> Either PackageVersion RawOpts
forall a. Mode a -> [PackageVersion] -> Either PackageVersion a
process Mode RawOpts
webmode [PackageVersion]
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 -> PackageVersion -> PackageVersion
[Capability] -> PackageVersion -> PackageVersion
Capability -> PackageVersion
(Int -> Capability -> PackageVersion -> PackageVersion)
-> (Capability -> PackageVersion)
-> ([Capability] -> PackageVersion -> PackageVersion)
-> Show Capability
forall a.
(Int -> a -> PackageVersion -> PackageVersion)
-> (a -> PackageVersion)
-> ([a] -> PackageVersion -> PackageVersion)
-> Show a
showList :: [Capability] -> PackageVersion -> PackageVersion
$cshowList :: [Capability] -> PackageVersion -> PackageVersion
show :: Capability -> PackageVersion
$cshow :: Capability -> PackageVersion
showsPrec :: Int -> Capability -> PackageVersion -> PackageVersion
$cshowsPrec :: Int -> Capability -> PackageVersion -> PackageVersion
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 :: PackageVersion -> Middleware
corsPolicyFromString PackageVersion
origin =
  let
    policy :: CorsResourcePolicy
policy = case PackageVersion
origin of
        PackageVersion
"*" -> CorsResourcePolicy
simpleCorsResourcePolicy
        PackageVersion
url -> ByteString -> CorsResourcePolicy
simplePolicyWithOrigin (ByteString -> CorsResourcePolicy)
-> ByteString -> CorsResourcePolicy
forall a b. (a -> b) -> a -> b
$ PackageVersion -> ByteString
fromString PackageVersion
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
-> (PackageVersion -> Middleware)
-> Maybe PackageVersion
-> Middleware
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Middleware
forall a. a -> a
id PackageVersion -> Middleware
corsPolicyFromString (Maybe PackageVersion -> Middleware)
-> Maybe PackageVersion -> Middleware
forall a b. (a -> b) -> a -> b
$ WebOpts -> Maybe PackageVersion
cors_ WebOpts
opts