{-# 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.Default (Default(def))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import System.Environment (getArgs)
import Network.Wai as WAI
import Network.Wai.Middleware.Cors
import Safe (lastMay)
import Hledger.Cli hiding (packageversion, progname, prognameandversion)
import Hledger.Web.Settings (defhost, defport, defbaseurl)
import qualified Data.Text as T
import Data.Char (toLower)
packageversion :: PackageVersion
packageversion :: String
packageversion =
#ifdef VERSION
VERSION
#else
""
#endif
progname :: ProgramName
progname :: String
progname = String
"hledger-web"
prognameandversion :: VersionString
prognameandversion :: String
prognameandversion = String -> String -> String
versionString String
progname String
packageversion
webflags :: [Flag RawOpts]
webflags :: [Flag RawOpts]
webflags =
[ 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"
, 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"
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"allow"]
(\String
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"allow" String
s RawOpts
opts)
String
"view|add|edit"
String
"set the user's access level for changing data (default: `add`). It also accepts `sandstorm` for use on that platform (reads permissions from the `X-Sandstorm-Permissions` request header)."
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"cors"]
(\String
s RawOpts
opts -> forall a b. b -> Either a b
Right 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")
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"socket"]
(\String
s RawOpts
opts -> forall a b. b -> Either a b
Right 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)"
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"host"]
(\String
s RawOpts
opts -> forall a b. b -> Either a b
Right 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: " forall a. [a] -> [a] -> [a]
++ String
defhost forall a. [a] -> [a] -> [a]
++ String
")")
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"port"]
(\String
s RawOpts
opts -> forall a b. b -> Either a b
Right 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: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
defport forall a. [a] -> [a] -> [a]
++ String
")")
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"base-url"]
(\String
s RawOpts
opts -> forall a b. b -> Either a b
Right 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)"
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"file-url"]
(\String
s RawOpts
opts -> forall a b. b -> Either a b
Right 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)"
, 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 =
(forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode
String
"hledger-web"
(String -> String -> RawOpts -> RawOpts
setopt String
"command" String
"web" 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
{ groupUnnamed :: [Flag RawOpts]
groupUnnamed = [Flag RawOpts]
webflags
, groupHidden :: [Flag RawOpts]
groupHidden =
[Flag RawOpts]
hiddenflags
, groupNamed :: [(String, [Flag RawOpts])]
groupNamed = [(String, [Flag RawOpts])
generalflagsgroup1]
}
, modeHelpSuffix :: [String]
modeHelpSuffix = []
}
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 -> AccessLevel
allow_ :: !AccessLevel
, WebOpts -> CliOpts
cliopts_ :: !CliOpts
, WebOpts -> Maybe String
socket_ :: !(Maybe String)
} deriving (Int -> WebOpts -> String -> String
[WebOpts] -> String -> String
WebOpts -> String
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
{ serve_ :: Bool
serve_ = Bool
False
, serve_api_ :: Bool
serve_api_ = Bool
False
, cors_ :: Maybe String
cors_ = forall a. Maybe a
Nothing
, host_ :: String
host_ = String
""
, port_ :: Int
port_ = forall a. Default a => a
def
, base_url_ :: String
base_url_ = String
""
, file_url_ :: Maybe String
file_url_ = forall a. Maybe a
Nothing
, allow_ :: AccessLevel
allow_ = AccessLevel
AddAccess
, cliopts_ :: CliOpts
cliopts_ = forall a. Default a => a
def
, socket_ :: Maybe String
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 :: String
h = forall a. a -> Maybe a -> a
fromMaybe String
defhost forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe String
maybestringopt String
"host" RawOpts
rawopts
p :: Int
p = forall a. a -> Maybe a -> a
fromMaybe Int
defport forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe Int
maybeposintopt String
"port" RawOpts
rawopts
b :: String
b = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Int -> String
defbaseurl String
h Int
p) String -> String
stripTrailingSlash forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe String
maybestringopt String
"base-url" RawOpts
rawopts
sock :: Maybe String
sock = String -> String
stripTrailingSlash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RawOpts -> Maybe String
maybestringopt String
"socket" RawOpts
rawopts
access :: AccessLevel
access =
case forall a. [a] -> Maybe a
lastMay forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> [String]
listofstringopt String
"allow" RawOpts
rawopts of
Maybe String
Nothing -> AccessLevel
AddAccess
Just String
t ->
case String -> Either String AccessLevel
parseAccessLevel String
t of
Right AccessLevel
al -> AccessLevel
al
Left String
err -> forall a. String -> a
error' (String
"Unknown access level: " forall a. [a] -> [a] -> [a]
++ String
err)
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RawOpts -> Maybe String
maybestringopt String
"file-url" RawOpts
rawopts
, allow_ :: AccessLevel
allow_ = AccessLevel
access
, cliopts_ :: CliOpts
cliopts_ = CliOpts
cliopts
, socket_ :: Maybe String
socket_ = Maybe String
sock
}
where
stripTrailingSlash :: String -> String
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
[String]
args <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> [String]
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
. [String] -> IO [String]
expandArgsAt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
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. String -> a
usageError forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> [String] -> Either String a
process Mode RawOpts
webmode [String]
args
data Permission
= ViewPermission
| AddPermission
| EditPermission
deriving (Permission -> Permission -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Permission -> Permission -> Bool
$c/= :: Permission -> Permission -> Bool
== :: Permission -> Permission -> Bool
$c== :: Permission -> Permission -> Bool
Eq, Eq Permission
Permission -> Permission -> Bool
Permission -> Permission -> Ordering
Permission -> Permission -> Permission
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 :: Permission -> Permission -> Permission
$cmin :: Permission -> Permission -> Permission
max :: Permission -> Permission -> Permission
$cmax :: Permission -> Permission -> Permission
>= :: Permission -> Permission -> Bool
$c>= :: Permission -> Permission -> Bool
> :: Permission -> Permission -> Bool
$c> :: Permission -> Permission -> Bool
<= :: Permission -> Permission -> Bool
$c<= :: Permission -> Permission -> Bool
< :: Permission -> Permission -> Bool
$c< :: Permission -> Permission -> Bool
compare :: Permission -> Permission -> Ordering
$ccompare :: Permission -> Permission -> Ordering
Ord, Permission
forall a. a -> a -> Bounded a
maxBound :: Permission
$cmaxBound :: Permission
minBound :: Permission
$cminBound :: Permission
Bounded, Int -> Permission
Permission -> Int
Permission -> [Permission]
Permission -> Permission
Permission -> Permission -> [Permission]
Permission -> Permission -> Permission -> [Permission]
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 :: Permission -> Permission -> Permission -> [Permission]
$cenumFromThenTo :: Permission -> Permission -> Permission -> [Permission]
enumFromTo :: Permission -> Permission -> [Permission]
$cenumFromTo :: Permission -> Permission -> [Permission]
enumFromThen :: Permission -> Permission -> [Permission]
$cenumFromThen :: Permission -> Permission -> [Permission]
enumFrom :: Permission -> [Permission]
$cenumFrom :: Permission -> [Permission]
fromEnum :: Permission -> Int
$cfromEnum :: Permission -> Int
toEnum :: Int -> Permission
$ctoEnum :: Int -> Permission
pred :: Permission -> Permission
$cpred :: Permission -> Permission
succ :: Permission -> Permission
$csucc :: Permission -> Permission
Enum, Int -> Permission -> String -> String
[Permission] -> String -> String
Permission -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Permission] -> String -> String
$cshowList :: [Permission] -> String -> String
show :: Permission -> String
$cshow :: Permission -> String
showsPrec :: Int -> Permission -> String -> String
$cshowsPrec :: Int -> Permission -> String -> String
Show)
parsePermission :: ByteString -> Either Text Permission
parsePermission :: ByteString -> Either Text Permission
parsePermission ByteString
"view" = forall a b. b -> Either a b
Right Permission
ViewPermission
parsePermission ByteString
"add" = forall a b. b -> Either a b
Right Permission
AddPermission
parsePermission ByteString
"edit" = forall a b. b -> Either a b
Right Permission
EditPermission
parsePermission ByteString
x = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
x
showPermission :: Permission -> String
showPermission :: Permission -> String
showPermission Permission
p = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
10 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Permission
p
data AccessLevel =
ViewAccess
| AddAccess
| EditAccess
| SandstormAccess
deriving (AccessLevel -> AccessLevel -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccessLevel -> AccessLevel -> Bool
$c/= :: AccessLevel -> AccessLevel -> Bool
== :: AccessLevel -> AccessLevel -> Bool
$c== :: AccessLevel -> AccessLevel -> Bool
Eq, Eq AccessLevel
AccessLevel -> AccessLevel -> Bool
AccessLevel -> AccessLevel -> Ordering
AccessLevel -> AccessLevel -> AccessLevel
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 :: AccessLevel -> AccessLevel -> AccessLevel
$cmin :: AccessLevel -> AccessLevel -> AccessLevel
max :: AccessLevel -> AccessLevel -> AccessLevel
$cmax :: AccessLevel -> AccessLevel -> AccessLevel
>= :: AccessLevel -> AccessLevel -> Bool
$c>= :: AccessLevel -> AccessLevel -> Bool
> :: AccessLevel -> AccessLevel -> Bool
$c> :: AccessLevel -> AccessLevel -> Bool
<= :: AccessLevel -> AccessLevel -> Bool
$c<= :: AccessLevel -> AccessLevel -> Bool
< :: AccessLevel -> AccessLevel -> Bool
$c< :: AccessLevel -> AccessLevel -> Bool
compare :: AccessLevel -> AccessLevel -> Ordering
$ccompare :: AccessLevel -> AccessLevel -> Ordering
Ord, AccessLevel
forall a. a -> a -> Bounded a
maxBound :: AccessLevel
$cmaxBound :: AccessLevel
minBound :: AccessLevel
$cminBound :: AccessLevel
Bounded, Int -> AccessLevel
AccessLevel -> Int
AccessLevel -> [AccessLevel]
AccessLevel -> AccessLevel
AccessLevel -> AccessLevel -> [AccessLevel]
AccessLevel -> AccessLevel -> AccessLevel -> [AccessLevel]
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 :: AccessLevel -> AccessLevel -> AccessLevel -> [AccessLevel]
$cenumFromThenTo :: AccessLevel -> AccessLevel -> AccessLevel -> [AccessLevel]
enumFromTo :: AccessLevel -> AccessLevel -> [AccessLevel]
$cenumFromTo :: AccessLevel -> AccessLevel -> [AccessLevel]
enumFromThen :: AccessLevel -> AccessLevel -> [AccessLevel]
$cenumFromThen :: AccessLevel -> AccessLevel -> [AccessLevel]
enumFrom :: AccessLevel -> [AccessLevel]
$cenumFrom :: AccessLevel -> [AccessLevel]
fromEnum :: AccessLevel -> Int
$cfromEnum :: AccessLevel -> Int
toEnum :: Int -> AccessLevel
$ctoEnum :: Int -> AccessLevel
pred :: AccessLevel -> AccessLevel
$cpred :: AccessLevel -> AccessLevel
succ :: AccessLevel -> AccessLevel
$csucc :: AccessLevel -> AccessLevel
Enum, Int -> AccessLevel -> String -> String
[AccessLevel] -> String -> String
AccessLevel -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AccessLevel] -> String -> String
$cshowList :: [AccessLevel] -> String -> String
show :: AccessLevel -> String
$cshow :: AccessLevel -> String
showsPrec :: Int -> AccessLevel -> String -> String
$cshowsPrec :: Int -> AccessLevel -> String -> String
Show)
parseAccessLevel :: String -> Either String AccessLevel
parseAccessLevel :: String -> Either String AccessLevel
parseAccessLevel String
"view" = forall a b. b -> Either a b
Right AccessLevel
ViewAccess
parseAccessLevel String
"add" = forall a b. b -> Either a b
Right AccessLevel
AddAccess
parseAccessLevel String
"edit" = forall a b. b -> Either a b
Right AccessLevel
EditAccess
parseAccessLevel String
"sandstorm" = forall a b. b -> Either a b
Right AccessLevel
SandstormAccess
parseAccessLevel String
s = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
s forall a. Semigroup a => a -> a -> a
<> String
", should be one of: view, add, edit, sandstorm"
accessLevelToPermissions :: AccessLevel -> [Permission]
accessLevelToPermissions :: AccessLevel -> [Permission]
accessLevelToPermissions AccessLevel
ViewAccess = [Permission
ViewPermission]
accessLevelToPermissions AccessLevel
AddAccess = [Permission
ViewPermission, Permission
AddPermission]
accessLevelToPermissions AccessLevel
EditAccess = [Permission
ViewPermission, Permission
AddPermission, Permission
EditPermission]
accessLevelToPermissions AccessLevel
SandstormAccess = []
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 :: String -> Middleware
corsPolicyFromString String
origin =
let
policy :: CorsResourcePolicy
policy = case String
origin of
String
"*" -> CorsResourcePolicy
simpleCorsResourcePolicy
String
url -> ByteString -> CorsResourcePolicy
simplePolicyWithOrigin forall a b. (a -> b) -> a -> b
$ String -> ByteString
fromString String
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 String -> Middleware
corsPolicyFromString forall a b. (a -> b) -> a -> b
$ WebOpts -> Maybe String
cors_ WebOpts
opts