{-# 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)
packageversion :: PackageVersion
packageversion :: [Char]
packageversion =
#ifdef VERSION
VERSION
#else
""
#endif
progname :: ProgramName
progname :: [Char]
progname = [Char]
"hledger-web"
prognameandversion :: VersionString
prognameandversion :: [Char]
prognameandversion = [Char] -> [Char] -> [Char]
versionString [Char]
progname [Char]
packageversion
webflags :: [Flag RawOpts]
webflags :: [Flag RawOpts]
webflags =
[ forall a. [[Char]] -> (a -> a) -> [Char] -> Flag a
flagNone
[[Char]
"serve", [Char]
"server"]
([Char] -> RawOpts -> RawOpts
setboolopt [Char]
"serve")
[Char]
"serve and log requests, don't browse or auto-exit"
, forall a. [[Char]] -> (a -> a) -> [Char] -> Flag a
flagNone
[[Char]
"serve-api"]
([Char] -> RawOpts -> RawOpts
setboolopt [Char]
"serve-api")
[Char]
"like --serve, but serve only the JSON web API, without the server-side web UI"
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"cors"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"cors" [Char]
s RawOpts
opts)
[Char]
"ORIGIN"
([Char]
"allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin")
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"socket"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"socket" [Char]
s RawOpts
opts)
[Char]
"SOCKET"
[Char]
"use the given socket instead of the given IP and port (implies --serve)"
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"host"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"host" [Char]
s RawOpts
opts)
[Char]
"IPADDR"
([Char]
"listen on this IP address (default: " forall a. [a] -> [a] -> [a]
++ [Char]
defhost forall a. [a] -> [a] -> [a]
++ [Char]
")")
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"port"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"port" [Char]
s RawOpts
opts)
[Char]
"PORT"
([Char]
"listen on this TCP port (default: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
defport forall a. [a] -> [a] -> [a]
++ [Char]
")")
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"base-url"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"base-url" [Char]
s RawOpts
opts)
[Char]
"BASEURL"
[Char]
"set the base url (default: http://IPADDR:PORT)"
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"file-url"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"file-url" [Char]
s RawOpts
opts)
[Char]
"FILEURL"
[Char]
"set the static files url (default: BASEURL/static)"
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"capabilities"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"capabilities" [Char]
s RawOpts
opts)
[Char]
"CAP[,CAP..]"
[Char]
"enable the view, add, and/or manage capabilities (default: view,add)"
, forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
[[Char]
"capabilities-header"]
(\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"capabilities-header" [Char]
s RawOpts
opts)
[Char]
"HTTPHEADER"
[Char]
"read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)"
, forall a. [[Char]] -> (a -> a) -> [Char] -> Flag a
flagNone
[[Char]
"test"]
([Char] -> RawOpts -> RawOpts
setboolopt [Char]
"test")
[Char]
"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 =
(forall a. [Char] -> a -> [Char] -> Arg a -> [Flag a] -> Mode a
mode
[Char]
"hledger-web"
([Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"command" [Char]
"web" forall a. Default a => a
def)
[Char]
"start serving the hledger web interface"
([Char] -> Arg RawOpts
argsFlag [Char]
"[PATTERNS]")
[])
{ modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags =
Group
{ groupUnnamed :: [Flag RawOpts]
groupUnnamed = [Flag RawOpts]
webflags
, groupHidden :: [Flag RawOpts]
groupHidden =
[Flag RawOpts]
hiddenflags
, groupNamed :: [([Char], [Flag RawOpts])]
groupNamed = [([Char], [Flag RawOpts])
generalflagsgroup1]
}
, modeHelpSuffix :: [[Char]]
modeHelpSuffix = []
}
data WebOpts = WebOpts
{ WebOpts -> Bool
serve_ :: Bool
, WebOpts -> Bool
serve_api_ :: Bool
, WebOpts -> Maybe [Char]
cors_ :: Maybe String
, WebOpts -> [Char]
host_ :: String
, WebOpts -> Int
port_ :: Int
, WebOpts -> [Char]
base_url_ :: String
, WebOpts -> Maybe [Char]
file_url_ :: Maybe String
, WebOpts -> [Capability]
capabilities_ :: [Capability]
, :: Maybe (CI ByteString)
, WebOpts -> CliOpts
cliopts_ :: CliOpts
, WebOpts -> Maybe [Char]
socket_ :: Maybe String
} deriving (Int -> WebOpts -> [Char] -> [Char]
[WebOpts] -> [Char] -> [Char]
WebOpts -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [WebOpts] -> [Char] -> [Char]
$cshowList :: [WebOpts] -> [Char] -> [Char]
show :: WebOpts -> [Char]
$cshow :: WebOpts -> [Char]
showsPrec :: Int -> WebOpts -> [Char] -> [Char]
$cshowsPrec :: Int -> WebOpts -> [Char] -> [Char]
Show)
defwebopts :: WebOpts
defwebopts :: WebOpts
defwebopts = WebOpts
{ serve_ :: Bool
serve_ = Bool
False
, serve_api_ :: Bool
serve_api_ = Bool
False
, cors_ :: Maybe [Char]
cors_ = forall a. Maybe a
Nothing
, host_ :: [Char]
host_ = [Char]
""
, port_ :: Int
port_ = forall a. Default a => a
def
, base_url_ :: [Char]
base_url_ = [Char]
""
, file_url_ :: Maybe [Char]
file_url_ = forall a. Maybe a
Nothing
, capabilities_ :: [Capability]
capabilities_ = [Capability
CapView, Capability
CapAdd]
, capabilitiesHeader_ :: Maybe (CI ByteString)
capabilitiesHeader_ = forall a. Maybe a
Nothing
, cliopts_ :: CliOpts
cliopts_ = forall a. Default a => a
def
, socket_ :: Maybe [Char]
socket_ = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
CliOpts
cliopts <- RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts
let h :: [Char]
h = forall a. a -> Maybe a -> a
fromMaybe [Char]
defhost forall a b. (a -> b) -> a -> b
$ [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"host" RawOpts
rawopts
p :: Int
p = forall a. a -> Maybe a -> a
fromMaybe Int
defport forall a b. (a -> b) -> a -> b
$ [Char] -> RawOpts -> Maybe Int
maybeposintopt [Char]
"port" RawOpts
rawopts
b :: [Char]
b =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Int -> [Char]
defbaseurl [Char]
h Int
p) [Char] -> [Char]
stripTrailingSlash forall a b. (a -> b) -> a -> b
$
[Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"base-url" RawOpts
rawopts
caps' :: [Text]
caps' = Text -> Text -> [Text]
T.splitOn Text
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> RawOpts -> [[Char]]
listofstringopt [Char]
"capabilities" RawOpts
rawopts
caps :: [Capability]
caps = case 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 -> forall a. [Char] -> a
error' ([Char]
"Unknown capability: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
e)
Right [] -> [Capability
CapView, Capability
CapAdd]
Right [Capability]
xs -> [Capability]
xs
sock :: Maybe [Char]
sock = [Char] -> [Char]
stripTrailingSlash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"socket" RawOpts
rawopts
forall (m :: * -> *) a. Monad m => a -> m a
return
WebOpts
defwebopts
{ serve_ :: Bool
serve_ = case Maybe [Char]
sock of
Just [Char]
_ -> Bool
True
Maybe [Char]
Nothing -> [Char] -> RawOpts -> Bool
boolopt [Char]
"serve" RawOpts
rawopts
, serve_api_ :: Bool
serve_api_ = [Char] -> RawOpts -> Bool
boolopt [Char]
"serve-api" RawOpts
rawopts
, cors_ :: Maybe [Char]
cors_ = [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"cors" RawOpts
rawopts
, host_ :: [Char]
host_ = [Char]
h
, port_ :: Int
port_ = Int
p
, base_url_ :: [Char]
base_url_ = [Char]
b
, file_url_ :: Maybe [Char]
file_url_ = [Char] -> [Char]
stripTrailingSlash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"file-url" RawOpts
rawopts
, capabilities_ :: [Capability]
capabilities_ = [Capability]
caps
, capabilitiesHeader_ :: Maybe (CI ByteString)
capabilitiesHeader_ = forall s. FoldCase s => s -> CI s
mk forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BC.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"capabilities-header" RawOpts
rawopts
, cliopts_ :: CliOpts
cliopts_ = CliOpts
cliopts
, socket_ :: Maybe [Char]
socket_ = Maybe [Char]
sock
}
where
stripTrailingSlash :: [Char] -> [Char]
stripTrailingSlash = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
checkWebOpts :: WebOpts -> WebOpts
checkWebOpts :: WebOpts -> WebOpts
checkWebOpts = forall a. a -> a
id
getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts = do
[[Char]]
args <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[Char]] -> [[Char]]
replaceNumericFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}.
(Eq (t Char), IsString (t Char), Foldable t) =>
[t Char] -> [t Char]
ensureDebugHasArg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> IO [[Char]]
expandArgsAt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [[Char]]
getArgs
RawOpts -> IO WebOpts
rawOptsToWebOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. [Char] -> a
usageError forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> [[Char]] -> Either [Char] a
process Mode RawOpts
webmode [[Char]]
args
data Capability
= CapView
| CapAdd
| CapManage
deriving (Capability -> Capability -> Bool
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
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
Ord, 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]
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 -> [Char] -> [Char]
[Capability] -> [Char] -> [Char]
Capability -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Capability] -> [Char] -> [Char]
$cshowList :: [Capability] -> [Char] -> [Char]
show :: Capability -> [Char]
$cshow :: Capability -> [Char]
showsPrec :: Int -> Capability -> [Char] -> [Char]
$cshowsPrec :: Int -> Capability -> [Char] -> [Char]
Show)
capabilityFromText :: Text -> Either Text Capability
capabilityFromText :: Text -> Either Text Capability
capabilityFromText Text
"view" = forall a b. b -> Either a b
Right Capability
CapView
capabilityFromText Text
"add" = forall a b. b -> Either a b
Right Capability
CapAdd
capabilityFromText Text
"manage" = forall a b. b -> Either a b
Right Capability
CapManage
capabilityFromText Text
x = forall a b. a -> Either a b
Left Text
x
capabilityFromBS :: ByteString -> Either ByteString Capability
capabilityFromBS :: ByteString -> Either ByteString Capability
capabilityFromBS ByteString
"view" = forall a b. b -> Either a b
Right Capability
CapView
capabilityFromBS ByteString
"add" = forall a b. b -> Either a b
Right Capability
CapAdd
capabilityFromBS ByteString
"manage" = forall a b. b -> Either a b
Right Capability
CapManage
capabilityFromBS ByteString
x = 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 = forall a. a -> Maybe a
Just ([ByteString
origin], Bool
False) }
corsPolicyFromString :: String -> WAI.Middleware
corsPolicyFromString :: [Char] -> Middleware
corsPolicyFromString [Char]
origin =
let
policy :: CorsResourcePolicy
policy = case [Char]
origin of
[Char]
"*" -> CorsResourcePolicy
simpleCorsResourcePolicy
[Char]
url -> ByteString -> CorsResourcePolicy
simplePolicyWithOrigin forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
fromString [Char]
url
in
(Request -> Maybe CorsResourcePolicy) -> Middleware
cors (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just CorsResourcePolicy
policy)
corsPolicy :: WebOpts -> (Application -> Application)
corsPolicy :: WebOpts -> Middleware
corsPolicy WebOpts
opts =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id [Char] -> Middleware
corsPolicyFromString forall a b. (a -> b) -> a -> b
$ WebOpts -> Maybe [Char]
cors_ WebOpts
opts