mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-18 17:57:11 +03:00
web: Add capabilities type, CLI options, and reading them from headers
This commit is contained in:
parent
930b38a345
commit
af98eecdf8
@ -164,74 +164,90 @@ const pkgdef :Spk.PackageDefinition = (
|
||||
# not have been detected as a dependency during `spk dev`. If you list
|
||||
# a directory here, its entire contents will be included recursively.
|
||||
|
||||
#bridgeConfig = (
|
||||
# # Used for integrating permissions and roles into the Sandstorm shell
|
||||
# # and for sandstorm-http-bridge to pass to your app.
|
||||
# # Uncomment this block and adjust the permissions and roles to make
|
||||
# # sense for your app.
|
||||
# # For more information, see high-level documentation at
|
||||
# # https://docs.sandstorm.io/en/latest/developing/auth/
|
||||
# # and advanced details in the "BridgeConfig" section of
|
||||
# # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/package.capnp
|
||||
# viewInfo = (
|
||||
# # For details on the viewInfo field, consult "ViewInfo" in
|
||||
# # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
|
||||
#
|
||||
# permissions = [
|
||||
# # Permissions which a user may or may not possess. A user's current
|
||||
# # permissions are passed to the app as a comma-separated list of `name`
|
||||
# # fields in the X-Sandstorm-Permissions header with each request.
|
||||
# #
|
||||
# # IMPORTANT: only ever append to this list! Reordering or removing fields
|
||||
# # will change behavior and permissions for existing grains! To deprecate a
|
||||
# # permission, or for more information, see "PermissionDef" in
|
||||
# # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
|
||||
# (
|
||||
# name = "editor",
|
||||
# # Name of the permission, used as an identifier for the permission in cases where string
|
||||
# # names are preferred. Used in sandstorm-http-bridge's X-Sandstorm-Permissions HTTP header.
|
||||
#
|
||||
# title = (defaultText = "editor"),
|
||||
# # Display name of the permission, e.g. to display in a checklist of permissions
|
||||
# # that may be assigned when sharing.
|
||||
#
|
||||
# description = (defaultText = "grants ability to modify data"),
|
||||
# # Prose describing what this role means, suitable for a tool tip or similar help text.
|
||||
# ),
|
||||
# ],
|
||||
# roles = [
|
||||
# # Roles are logical collections of permissions. For instance, your app may have
|
||||
# # a "viewer" role and an "editor" role
|
||||
# (
|
||||
# title = (defaultText = "editor"),
|
||||
# # Name of the role. Shown in the Sandstorm UI to indicate which users have which roles.
|
||||
#
|
||||
# permissions = [true],
|
||||
# # An array indicating which permissions this role carries.
|
||||
# # It should be the same length as the permissions array in
|
||||
# # viewInfo, and the order of the lists must match.
|
||||
#
|
||||
# verbPhrase = (defaultText = "can make changes to the document"),
|
||||
# # Brief explanatory text to show in the sharing UI indicating
|
||||
# # what a user assigned this role will be able to do with the grain.
|
||||
#
|
||||
# description = (defaultText = "editors may view all site data and change settings."),
|
||||
# # Prose describing what this role means, suitable for a tool tip or similar help text.
|
||||
# ),
|
||||
# (
|
||||
# title = (defaultText = "viewer"),
|
||||
# permissions = [false],
|
||||
# verbPhrase = (defaultText = "can view the document"),
|
||||
# description = (defaultText = "viewers may view what other users have written."),
|
||||
# ),
|
||||
# ],
|
||||
# ),
|
||||
# #apiPath = "/api",
|
||||
# # Apps can export an API to the world. The API is to be used primarily by Javascript
|
||||
# # code and native apps, so it can't serve out regular HTML to browsers. If a request
|
||||
# # comes in to your app's API, sandstorm-http-bridge will prefix the request's path with
|
||||
# # this string, if specified.
|
||||
#),
|
||||
bridgeConfig = (
|
||||
# Used for integrating permissions and roles into the Sandstorm shell
|
||||
# and for sandstorm-http-bridge to pass to your app.
|
||||
# Uncomment this block and adjust the permissions and roles to make
|
||||
# sense for your app.
|
||||
# For more information, see high-level documentation at
|
||||
# https://docs.sandstorm.io/en/latest/developing/auth/
|
||||
# and advanced details in the "BridgeConfig" section of
|
||||
# https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/package.capnp
|
||||
viewInfo = (
|
||||
# For details on the viewInfo field, consult "ViewInfo" in
|
||||
# https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
|
||||
|
||||
permissions = [
|
||||
# Permissions which a user may or may not possess. A user's current
|
||||
# permissions are passed to the app as a comma-separated list of `name`
|
||||
# fields in the X-Sandstorm-Permissions header with each request.
|
||||
#
|
||||
# IMPORTANT: only ever append to this list! Reordering or removing fields
|
||||
# will change behavior and permissions for existing grains! To deprecate a
|
||||
# permission, or for more information, see "PermissionDef" in
|
||||
# https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
|
||||
(
|
||||
name = "view",
|
||||
# Name of the permission, used as an identifier for the permission in cases where string
|
||||
# names are preferred. Used in sandstorm-http-bridge's X-Sandstorm-Permissions HTTP header.
|
||||
|
||||
title = (defaultText = "view"),
|
||||
# Display name of the permission, e.g. to display in a checklist of permissions
|
||||
# that may be assigned when sharing.
|
||||
|
||||
description = (defaultText = "grants ability to view the ledger"),
|
||||
# Prose describing what this role means, suitable for a tool tip or similar help text.
|
||||
),
|
||||
(
|
||||
name = "add",
|
||||
title = (defaultText = "add"),
|
||||
description = (defaultText = "grants ability to append transactions to the ledger"),
|
||||
),
|
||||
(
|
||||
name = "manage",
|
||||
title = (defaultText = "manage"),
|
||||
description = (defaultText = "grants ability to modify or replace the entire ledger"),
|
||||
),
|
||||
],
|
||||
roles = [
|
||||
# Roles are logical collections of permissions. For instance, your app may have
|
||||
# a "viewer" role and an "editor" role
|
||||
(
|
||||
title = (defaultText = "manager"),
|
||||
# Name of the role. Shown in the Sandstorm UI to indicate which users have which roles.
|
||||
|
||||
permissions = [true, true, true],
|
||||
# An array indicating which permissions this role carries.
|
||||
# It should be the same length as the permissions array in
|
||||
# viewInfo, and the order of the lists must match.
|
||||
|
||||
verbPhrase = (defaultText = "has full access to the ledger"),
|
||||
# Brief explanatory text to show in the sharing UI indicating
|
||||
# what a user assigned this role will be able to do with the grain.
|
||||
|
||||
description = (defaultText = "managers can modify the ledger in any way."),
|
||||
# Prose describing what this role means, suitable for a tool tip or similar help text.
|
||||
),
|
||||
(
|
||||
title = (defaultText = "editor"),
|
||||
permissions = [true, true, false],
|
||||
verbPhrase = (defaultText = "can append new transactions"),
|
||||
description = (defaultText = "editors can view the ledger or append new transactions to it."),
|
||||
),
|
||||
(
|
||||
title = (defaultText = "viewer"),
|
||||
permissions = [true, false, false],
|
||||
verbPhrase = (defaultText = "can view the ledger"),
|
||||
description = (defaultText = "viewers can only view the ledger."),
|
||||
),
|
||||
],
|
||||
),
|
||||
#apiPath = "/api",
|
||||
# Apps can export an API to the world. The API is to be used primarily by Javascript
|
||||
# code and native apps, so it can't serve out regular HTML to browsers. If a request
|
||||
# comes in to your app's API, sandstorm-http-bridge will prefix the request's path with
|
||||
# this string, if specified.
|
||||
),
|
||||
);
|
||||
|
||||
const myCommand :Spk.Manifest.Command = (
|
||||
|
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
import "hledger-web" Application (getApplicationDev)
|
||||
import "hledger-web" Hledger.Web.Main (hledgerWebDev)
|
||||
import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort)
|
||||
import Control.Concurrent (forkIO)
|
||||
import System.Directory (doesFileExist, removeFile)
|
||||
@ -9,7 +9,7 @@ import Control.Concurrent (threadDelay)
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Starting devel application"
|
||||
(port, app) <- getApplicationDev
|
||||
(port, app) <- hledgerWebDev
|
||||
forkIO $ runSettings (setPort port defaultSettings) app
|
||||
loop
|
||||
|
||||
|
@ -156,6 +156,7 @@ library
|
||||
, blaze-html
|
||||
, blaze-markup
|
||||
, bytestring
|
||||
, case-insensitive
|
||||
, clientsession
|
||||
, cmdargs >=0.10
|
||||
, conduit
|
||||
|
@ -103,6 +103,7 @@ library:
|
||||
- blaze-html
|
||||
- blaze-markup
|
||||
- bytestring
|
||||
- case-insensitive
|
||||
- clientsession
|
||||
- cmdargs >=0.10
|
||||
- conduit
|
||||
|
@ -6,19 +6,16 @@
|
||||
|
||||
module Application
|
||||
( makeApplication
|
||||
, getApplicationDev
|
||||
, makeFoundation
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Data.Default (def)
|
||||
import Data.IORef (newIORef, writeIORef)
|
||||
import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
|
||||
import Network.HTTP.Client (defaultManagerSettings)
|
||||
import Network.HTTP.Conduit (newManager)
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Main (defaultDevelApp)
|
||||
|
||||
import Handler.AddR (getAddR, postAddR)
|
||||
import Handler.Common
|
||||
@ -28,10 +25,7 @@ import Handler.UploadR (getUploadR, postUploadR)
|
||||
import Handler.JournalR (getJournalR)
|
||||
import Handler.RegisterR (getRegisterR)
|
||||
import Hledger.Data (Journal, nulljournal)
|
||||
import Hledger.Read (readJournalFile)
|
||||
import Hledger.Utils (error')
|
||||
import Hledger.Cli.CliOptions (defcliopts, journalFilePathFromOpts)
|
||||
import Hledger.Web.WebOptions (WebOpts(..), defwebopts)
|
||||
import Hledger.Web.WebOptions (WebOpts(serve_))
|
||||
|
||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
|
||||
@ -58,15 +52,3 @@ makeFoundation conf opts' = do
|
||||
s <- staticSite
|
||||
jref <- newIORef nulljournal
|
||||
return $ App conf s manager opts' jref
|
||||
|
||||
-- for yesod devel
|
||||
-- uses the journal specified by the LEDGER_FILE env var, or ~/.hledger.journal
|
||||
getApplicationDev :: IO (Int, Application)
|
||||
getApplicationDev = do
|
||||
f <- head `fmap` journalFilePathFromOpts defcliopts -- XXX head should be safe for now
|
||||
j' <- either error' id <$> readJournalFile def f
|
||||
defaultDevelApp loader (makeApplication defwebopts j')
|
||||
where
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
}
|
||||
|
@ -16,12 +16,17 @@
|
||||
|
||||
module Foundation where
|
||||
|
||||
import Control.Monad (join)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.Traversable (for)
|
||||
import Data.IORef (IORef, readIORef, writeIORef)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar (Day)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Network.Wai (requestHeaders)
|
||||
import System.FilePath (takeFileName)
|
||||
import Text.Blaze (Markup)
|
||||
import Text.Hamlet (hamletFile)
|
||||
@ -166,12 +171,13 @@ instance RenderMessage App FormMessage where
|
||||
|
||||
-- | A bundle of data useful for hledger-web request handlers and templates.
|
||||
data ViewData = VD
|
||||
{ opts :: WebOpts -- ^ the command-line options at startup
|
||||
, today :: Day -- ^ today's date (for queries containing relative dates)
|
||||
, j :: Journal -- ^ the up-to-date parsed unfiltered journal
|
||||
, q :: Text -- ^ the current q parameter, the main query expression
|
||||
, m :: Query -- ^ a query parsed from the q parameter
|
||||
, qopts :: [QueryOpt] -- ^ query options parsed from the q parameter
|
||||
{ opts :: WebOpts -- ^ the command-line options at startup
|
||||
, today :: Day -- ^ today's date (for queries containing relative dates)
|
||||
, j :: Journal -- ^ the up-to-date parsed unfiltered journal
|
||||
, q :: Text -- ^ the current q parameter, the main query expression
|
||||
, m :: Query -- ^ a query parsed from the q parameter
|
||||
, qopts :: [QueryOpt] -- ^ query options parsed from the q parameter
|
||||
, caps :: [Capability] -- ^ capabilities enabled for this request
|
||||
} deriving (Show)
|
||||
|
||||
instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
|
||||
@ -179,26 +185,25 @@ instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
|
||||
-- | Gather data used by handlers and templates in the current request.
|
||||
getViewData :: Handler ViewData
|
||||
getViewData = do
|
||||
y <- getYesod
|
||||
App {appOpts = opts, appJournal} <- getYesod
|
||||
today <- liftIO getCurrentDay
|
||||
let copts = cliopts_ (appOpts y)
|
||||
let copts = cliopts_ opts
|
||||
(j, merr) <-
|
||||
getCurrentJournal
|
||||
(appJournal y)
|
||||
appJournal
|
||||
copts {reportopts_ = (reportopts_ copts) {no_elide_ = True}}
|
||||
today
|
||||
maybe (pure ()) (setMessage . toHtml) merr
|
||||
q <- fromMaybe "" <$> lookupGetParam "q"
|
||||
let (querymatcher, queryopts) = parseQuery today q
|
||||
return
|
||||
VD
|
||||
{ opts = appOpts y
|
||||
, today = today
|
||||
, j = j
|
||||
, q = q
|
||||
, m = querymatcher
|
||||
, qopts = queryopts
|
||||
}
|
||||
let (m, qopts) = parseQuery today q
|
||||
caps <- case capabilitiesHeader_ opts of
|
||||
Nothing -> return (capabilities_ opts)
|
||||
Just h -> do
|
||||
hs <- fmap snd . filter ((== h) . fst) . requestHeaders <$> waiRequest
|
||||
fmap join . for hs $ \x -> case capabilityFromBS x of
|
||||
Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml (BC.unpack e))
|
||||
Right c -> pure [c]
|
||||
return VD {opts, today, j, q, m, qopts, caps}
|
||||
|
||||
-- | Find out if the sidebar should be visible. Show it, unless there is a
|
||||
-- showsidebar cookie set to "0", or a ?sidebar=0 query parameter.
|
||||
|
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE CPP, OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-|
|
||||
|
||||
hledger-web - a hledger add-on providing a web interface.
|
||||
@ -9,23 +11,26 @@ Released under GPL version 3 or later.
|
||||
|
||||
module Hledger.Web.Main where
|
||||
|
||||
import Control.Monad ((<=<), when)
|
||||
import Data.Default (def)
|
||||
import Control.Monad (when)
|
||||
import Data.String (fromString)
|
||||
import qualified Data.Text as T
|
||||
import Data.Foldable (traverse_)
|
||||
import Network.Wai (Application)
|
||||
import Network.Wai.Handler.Warp (runSettings, defaultSettings, setHost, setPort)
|
||||
import Network.Wai.Handler.Launch (runHostPortUrl)
|
||||
import Prelude hiding (putStrLn)
|
||||
import System.Exit (exitSuccess)
|
||||
import System.IO (hFlush, stdout)
|
||||
import Text.Printf (printf)
|
||||
import Yesod.Default.Config (AppConfig(..), DefaultEnv(Development))
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Main (defaultDevelApp)
|
||||
|
||||
import Application (makeApplication)
|
||||
import Settings (Extra(..))
|
||||
import Settings (Extra(..), parseExtra)
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli hiding (progname,prognameandversion)
|
||||
import Hledger.Cli.Utils (journalTransform)
|
||||
import Hledger.Utils.UTF8IOCompat (putStrLn)
|
||||
import Hledger.Web.WebOptions
|
||||
|
||||
@ -36,6 +41,14 @@ hledgerWebMain = do
|
||||
when (debug_ (cliopts_ opts) > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)
|
||||
runWith opts
|
||||
|
||||
hledgerWebDev :: IO (Int, Application)
|
||||
hledgerWebDev =
|
||||
withJournalDo' defwebopts (\o j -> defaultDevelApp loader $ makeApplication o j)
|
||||
where
|
||||
loader =
|
||||
Yesod.Default.Config.loadConfig
|
||||
(configSettings Development) {csParseExtra = parseExtra}
|
||||
|
||||
runWith :: WebOpts -> IO ()
|
||||
runWith opts
|
||||
| "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess
|
||||
@ -86,10 +99,7 @@ web opts j = do
|
||||
then do
|
||||
putStrLn "Press ctrl-c to quit"
|
||||
hFlush stdout
|
||||
let warpsettings =
|
||||
setHost (fromString h) $
|
||||
setPort p $
|
||||
defaultSettings
|
||||
let warpsettings = setHost (fromString h) (setPort p defaultSettings)
|
||||
Network.Wai.Handler.Warp.runSettings warpsettings app
|
||||
else do
|
||||
putStrLn "Starting web browser..."
|
||||
|
@ -1,8 +1,15 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Hledger.Web.WebOptions where
|
||||
|
||||
import Data.Default (def)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
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 Settings (defhost, defport, defbaseurl)
|
||||
@ -19,81 +26,137 @@ version = ""
|
||||
prognameandversion :: String
|
||||
prognameandversion = progname ++ " " ++ version :: String
|
||||
|
||||
webflags :: [Flag [([Char], [Char])]]
|
||||
webflags = [
|
||||
flagNone ["serve","server"] (setboolopt "serve") ("serve and log requests, don't browse or auto-exit")
|
||||
,flagReq ["host"] (\s opts -> Right $ setopt "host" s opts) "IPADDR" ("listen on this IP address (default: "++defhost++")")
|
||||
,flagReq ["port"] (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this TCP port (default: "++show defport++")")
|
||||
,flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "BASEURL" ("set the base url (default: http://IPADDR:PORT)")
|
||||
,flagReq ["file-url"] (\s opts -> Right $ setopt "file-url" s opts) "FILEURL" ("set the static files url (default: BASEURL/static)")
|
||||
]
|
||||
webflags :: [Flag [(String, String)]]
|
||||
webflags =
|
||||
[ flagNone
|
||||
["serve", "server"]
|
||||
(setboolopt "serve")
|
||||
"serve and log requests, don't browse or auto-exit"
|
||||
, flagReq
|
||||
["host"]
|
||||
(\s opts -> Right $ setopt "host" s opts)
|
||||
"IPADDR"
|
||||
("listen on this IP address (default: " ++ defhost ++ ")")
|
||||
, flagReq
|
||||
["port"]
|
||||
(\s opts -> Right $ setopt "port" s opts)
|
||||
"PORT"
|
||||
("listen on this TCP port (default: " ++ show defport ++ ")")
|
||||
, flagReq
|
||||
["base-url"]
|
||||
(\s opts -> Right $ setopt "base-url" s opts)
|
||||
"BASEURL"
|
||||
"set the base url (default: http://IPADDR:PORT)"
|
||||
, flagReq
|
||||
["file-url"]
|
||||
(\s opts -> Right $ setopt "file-url" s opts)
|
||||
"FILEURL"
|
||||
"set the static files url (default: BASEURL/static)"
|
||||
, flagReq
|
||||
["capabilities"]
|
||||
(\s opts -> Right $ setopt "capabilities" s opts)
|
||||
"CAP,CAP2"
|
||||
"enable these capabilities - comma-separated, possible values are: view, add, manage (default: view,add)"
|
||||
, flagReq
|
||||
["capabilities-from-header"]
|
||||
(\s opts -> Right $ setopt "capabilities-from-header" s opts)
|
||||
"HEADER"
|
||||
"read enabled capabilities from a HTTP header (e.g. X-Sandstorm-Permissions, disabled by default)"
|
||||
]
|
||||
|
||||
webmode :: Mode [([Char], [Char])]
|
||||
webmode = (mode "hledger-web" [("command","web")]
|
||||
"start serving the hledger web interface"
|
||||
(argsFlag "[PATTERNS]") []){
|
||||
modeGroupFlags = Group {
|
||||
groupUnnamed = webflags
|
||||
,groupHidden = [flagNone ["binary-filename"] (setboolopt "binary-filename") "show the download filename for this executable, and exit"]
|
||||
,groupNamed = [generalflagsgroup1]
|
||||
}
|
||||
,modeHelpSuffix=[
|
||||
-- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."
|
||||
]
|
||||
}
|
||||
webmode :: Mode [(String, String)]
|
||||
webmode =
|
||||
(mode
|
||||
"hledger-web"
|
||||
[("command", "web")]
|
||||
"start serving the hledger web interface"
|
||||
(argsFlag "[PATTERNS]")
|
||||
[])
|
||||
{ modeGroupFlags =
|
||||
Group
|
||||
{ groupUnnamed = webflags
|
||||
, groupHidden =
|
||||
[ flagNone
|
||||
["binary-filename"]
|
||||
(setboolopt "binary-filename")
|
||||
"show the download filename for this executable, and exit"
|
||||
]
|
||||
, groupNamed = [generalflagsgroup1]
|
||||
}
|
||||
, modeHelpSuffix = []
|
||||
}
|
||||
|
||||
-- hledger-web options, used in hledger-web and above
|
||||
data WebOpts = WebOpts {
|
||||
serve_ :: Bool
|
||||
,host_ :: String
|
||||
,port_ :: Int
|
||||
,base_url_ :: String
|
||||
,file_url_ :: Maybe String
|
||||
,cliopts_ :: CliOpts
|
||||
} deriving (Show)
|
||||
data WebOpts = WebOpts
|
||||
{ serve_ :: Bool
|
||||
, host_ :: String
|
||||
, port_ :: Int
|
||||
, base_url_ :: String
|
||||
, file_url_ :: Maybe String
|
||||
, capabilities_ :: [Capability]
|
||||
, capabilitiesHeader_ :: Maybe (CI ByteString)
|
||||
, cliopts_ :: CliOpts
|
||||
} deriving (Show)
|
||||
|
||||
defwebopts :: WebOpts
|
||||
defwebopts = WebOpts
|
||||
def
|
||||
def
|
||||
def
|
||||
def
|
||||
def
|
||||
def
|
||||
defwebopts = WebOpts def def def def def [CapView, CapAdd] Nothing def
|
||||
|
||||
-- instance Default WebOpts where def = defwebopts
|
||||
instance Default WebOpts where def = defwebopts
|
||||
|
||||
rawOptsToWebOpts :: RawOpts -> IO WebOpts
|
||||
rawOptsToWebOpts rawopts = checkWebOpts <$> do
|
||||
cliopts <- rawOptsToCliOpts rawopts
|
||||
let
|
||||
h = fromMaybe defhost $ maybestringopt "host" rawopts
|
||||
p = fromMaybe defport $ maybeintopt "port" rawopts
|
||||
b = maybe (defbaseurl h p) stripTrailingSlash $ maybestringopt "base-url" rawopts
|
||||
return defwebopts {
|
||||
serve_ = boolopt "serve" rawopts
|
||||
,host_ = h
|
||||
,port_ = p
|
||||
,base_url_ = b
|
||||
,file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
|
||||
,cliopts_ = cliopts
|
||||
}
|
||||
rawOptsToWebOpts rawopts =
|
||||
checkWebOpts <$> do
|
||||
cliopts <- rawOptsToCliOpts rawopts
|
||||
let h = fromMaybe defhost $ maybestringopt "host" rawopts
|
||||
p = fromMaybe defport $ maybeintopt "port" rawopts
|
||||
b =
|
||||
maybe (defbaseurl h p) stripTrailingSlash $
|
||||
maybestringopt "base-url" rawopts
|
||||
caps' = join $ T.splitOn "," . T.pack <$> listofstringopt "capabilities" rawopts
|
||||
caps = case traverse capabilityFromText caps' of
|
||||
Left e -> error' ("Unknown capability: " ++ T.unpack e)
|
||||
Right [] -> [CapView, CapAdd]
|
||||
Right xs -> xs
|
||||
return
|
||||
defwebopts
|
||||
{ serve_ = boolopt "serve" rawopts
|
||||
, host_ = h
|
||||
, port_ = p
|
||||
, base_url_ = b
|
||||
, file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
|
||||
, capabilities_ = caps
|
||||
, capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-from-header" rawopts
|
||||
, cliopts_ = cliopts
|
||||
}
|
||||
where
|
||||
stripTrailingSlash = reverse . dropWhile (=='/') . reverse -- yesod don't like it
|
||||
stripTrailingSlash = reverse . dropWhile (== '/') . reverse -- yesod don't like it
|
||||
|
||||
checkWebOpts :: WebOpts -> WebOpts
|
||||
checkWebOpts wopts =
|
||||
either usageError (const wopts) $ do
|
||||
let h = host_ wopts
|
||||
if any (not . (`elem` ".0123456789")) h
|
||||
then Left $ "--host requires an IP address, not "++show h
|
||||
else Right ()
|
||||
checkWebOpts wopts = do
|
||||
let h = host_ wopts
|
||||
if any (`notElem` (".0123456789" :: String)) h
|
||||
then usageError $ "--host requires an IP address, not " ++ show h
|
||||
else wopts
|
||||
|
||||
getHledgerWebOpts :: IO WebOpts
|
||||
--getHledgerWebOpts = processArgs webmode >>= return . decodeRawOpts >>= rawOptsToWebOpts
|
||||
getHledgerWebOpts = do
|
||||
args <- getArgs >>= expandArgsAt
|
||||
let args' = replaceNumericFlags args
|
||||
let cmdargopts = either usageError id $ process webmode args'
|
||||
rawOptsToWebOpts $ decodeRawOpts cmdargopts
|
||||
args <- fmap replaceNumericFlags . expandArgsAt =<< getArgs
|
||||
rawOptsToWebOpts . decodeRawOpts . either usageError id $ process webmode args
|
||||
|
||||
data Capability
|
||||
= CapView
|
||||
| CapAdd
|
||||
| CapManage
|
||||
deriving (Eq, Ord, Bounded, Enum, Show)
|
||||
|
||||
capabilityFromText :: Text -> Either Text Capability
|
||||
capabilityFromText "view" = Right CapView
|
||||
capabilityFromText "add" = Right CapAdd
|
||||
capabilityFromText "manage" = Right CapManage
|
||||
capabilityFromText x = Left x
|
||||
|
||||
capabilityFromBS :: ByteString -> Either ByteString Capability
|
||||
capabilityFromBS "view" = Right CapView
|
||||
capabilityFromBS "add" = Right CapAdd
|
||||
capabilityFromBS "manage" = Right CapManage
|
||||
capabilityFromBS x = Left x
|
||||
|
@ -11,7 +11,7 @@ module Hledger.Cli.Utils
|
||||
withJournalDo,
|
||||
writeOutput,
|
||||
journalTransform,
|
||||
journalApplyValue,
|
||||
journalApplyValue,
|
||||
journalAddForecast,
|
||||
generateAutomaticPostings,
|
||||
journalReload,
|
||||
|
Loading…
Reference in New Issue
Block a user