mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-19 10:17:35 +03:00
web: Add capabilities guards and conditional widget rendering
This commit is contained in:
parent
e8668e2a5c
commit
483283ec43
6
Makefile
6
Makefile
@ -134,11 +134,7 @@ SOURCEFILES:= \
|
|||||||
hledger-*/Hledger/*hs \
|
hledger-*/Hledger/*hs \
|
||||||
hledger-*/Hledger/*/*hs \
|
hledger-*/Hledger/*/*hs \
|
||||||
hledger-lib/other/ledger-parse/Ledger/Parser/*hs \
|
hledger-lib/other/ledger-parse/Ledger/Parser/*hs \
|
||||||
hledger-web/app/*.hs \
|
hledger-web/**/*.hs \
|
||||||
hledger-web/tests/*.hs \
|
|
||||||
hledger-web/Handler/*.hs \
|
|
||||||
hledger-web/Hledger/*.hs \
|
|
||||||
hledger-web/Settings/*.hs \
|
|
||||||
|
|
||||||
HPACKFILES:= \
|
HPACKFILES:= \
|
||||||
hledger/*package.yaml \
|
hledger/*package.yaml \
|
||||||
|
@ -101,7 +101,7 @@ instance Yesod App where
|
|||||||
defaultLayout widget = do
|
defaultLayout widget = do
|
||||||
master <- getYesod
|
master <- getYesod
|
||||||
here <- fromMaybe RootR <$> getCurrentRoute
|
here <- fromMaybe RootR <$> getCurrentRoute
|
||||||
VD {j, m, opts, q, qopts} <- getViewData
|
VD {caps, j, m, opts, q, qopts} <- getViewData
|
||||||
msg <- getMessage
|
msg <- getMessage
|
||||||
showSidebar <- shouldShowSidebar
|
showSidebar <- shouldShowSidebar
|
||||||
hideEmptyAccts <- (== Just "1") . lookup "hideemptyaccts" . reqCookies <$> getRequest
|
hideEmptyAccts <- (== Just "1") . lookup "hideemptyaccts" . reqCookies <$> getRequest
|
||||||
@ -198,8 +198,8 @@ getViewData = do
|
|||||||
caps <- case capabilitiesHeader_ opts of
|
caps <- case capabilitiesHeader_ opts of
|
||||||
Nothing -> return (capabilities_ opts)
|
Nothing -> return (capabilities_ opts)
|
||||||
Just h -> do
|
Just h -> do
|
||||||
hs <- fmap snd . filter ((== h) . fst) . requestHeaders <$> waiRequest
|
hs <- fmap (BC.split ',' . snd) . filter ((== h) . fst) . requestHeaders <$> waiRequest
|
||||||
fmap join . for hs $ \x -> case capabilityFromBS x of
|
fmap join . for (join hs) $ \x -> case capabilityFromBS x of
|
||||||
Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml (BC.unpack e))
|
Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml (BC.unpack e))
|
||||||
Right c -> pure [c]
|
Right c -> pure [c]
|
||||||
return VD {opts, today, j, q, m, qopts, caps}
|
return VD {opts, today, j, q, m, qopts, caps}
|
||||||
|
@ -20,7 +20,9 @@ getAddR = postAddR
|
|||||||
|
|
||||||
postAddR :: Handler ()
|
postAddR :: Handler ()
|
||||||
postAddR = do
|
postAddR = do
|
||||||
VD{j, today} <- getViewData
|
VD{caps, j, today} <- getViewData
|
||||||
|
when (CapAdd `notElem` caps) (permissionDenied "Missing the 'add' capability")
|
||||||
|
|
||||||
((res, view), enctype) <- runFormPost $ addForm j today
|
((res, view), enctype) <- runFormPost $ addForm j today
|
||||||
t <- txnTieKnot <$> fromFormSuccess (showForm view enctype) res
|
t <- txnTieKnot <$> fromFormSuccess (showForm view enctype) res
|
||||||
-- XXX(?) move into balanceTransaction
|
-- XXX(?) move into balanceTransaction
|
||||||
|
@ -27,7 +27,9 @@ getEditR = postEditR
|
|||||||
|
|
||||||
postEditR :: FilePath -> Handler ()
|
postEditR :: FilePath -> Handler ()
|
||||||
postEditR f = do
|
postEditR f = do
|
||||||
VD {j} <- getViewData
|
VD {caps, j} <- getViewData
|
||||||
|
when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability")
|
||||||
|
|
||||||
(f', txt) <- journalFile404 f j
|
(f', txt) <- journalFile404 f j
|
||||||
((res, view), enctype) <- runFormPost (editForm f' txt)
|
((res, view), enctype) <- runFormPost (editForm f' txt)
|
||||||
text <- fromFormSuccess (showForm view enctype) res
|
text <- fromFormSuccess (showForm view enctype) res
|
||||||
|
@ -15,10 +15,10 @@ import Hledger.Web.Widget.AddForm (addModal)
|
|||||||
import Hledger.Web.Widget.Common (accountQuery, mixedAmountAsHtml)
|
import Hledger.Web.Widget.Common (accountQuery, mixedAmountAsHtml)
|
||||||
|
|
||||||
-- | The formatted journal view, with sidebar.
|
-- | The formatted journal view, with sidebar.
|
||||||
-- XXX like registerReportAsHtml
|
|
||||||
getJournalR :: Handler Html
|
getJournalR :: Handler Html
|
||||||
getJournalR = do
|
getJournalR = do
|
||||||
VD{j, m, opts, qopts, today} <- getViewData
|
VD{caps, j, m, opts, qopts, today} <- getViewData
|
||||||
|
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability")
|
||||||
let title = case inAccount qopts of
|
let title = case inAccount qopts of
|
||||||
Nothing -> "General Journal"
|
Nothing -> "General Journal"
|
||||||
Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)"
|
Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)"
|
||||||
|
@ -22,7 +22,9 @@ import Hledger.Web.Widget.Common (mixedAmountAsHtml)
|
|||||||
-- | The main journal/account register view, with accounts sidebar.
|
-- | The main journal/account register view, with accounts sidebar.
|
||||||
getRegisterR :: Handler Html
|
getRegisterR :: Handler Html
|
||||||
getRegisterR = do
|
getRegisterR = do
|
||||||
VD{j, m, opts, qopts, today} <- getViewData
|
VD{caps, j, m, opts, qopts, today} <- getViewData
|
||||||
|
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability")
|
||||||
|
|
||||||
let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
|
let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
|
||||||
s1 = if inclsubs then "" else " (excluding subaccounts)"
|
s1 = if inclsubs then "" else " (excluding subaccounts)"
|
||||||
s2 = if m /= Any then ", filtered" else ""
|
s2 = if m /= Any then ", filtered" else ""
|
||||||
|
@ -31,7 +31,9 @@ getUploadR = postUploadR
|
|||||||
|
|
||||||
postUploadR :: FilePath -> Handler ()
|
postUploadR :: FilePath -> Handler ()
|
||||||
postUploadR f = do
|
postUploadR f = do
|
||||||
VD {j} <- getViewData
|
VD {caps, j} <- getViewData
|
||||||
|
when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability")
|
||||||
|
|
||||||
(f', _) <- journalFile404 f j
|
(f', _) <- journalFile404 f j
|
||||||
((res, view), enctype) <- runFormPost (uploadForm f')
|
((res, view), enctype) <- runFormPost (uploadForm f')
|
||||||
fi <- fromFormSuccess (showForm view enctype) res
|
fi <- fromFormSuccess (showForm view enctype) res
|
||||||
|
@ -24,6 +24,7 @@ import Text.Blaze as Import (Markup)
|
|||||||
import Hledger.Web.Foundation as Import
|
import Hledger.Web.Foundation as Import
|
||||||
import Hledger.Web.Settings as Import
|
import Hledger.Web.Settings as Import
|
||||||
import Hledger.Web.Settings.StaticFiles as Import
|
import Hledger.Web.Settings.StaticFiles as Import
|
||||||
|
import Hledger.Web.WebOptions as Import (Capability(..))
|
||||||
|
|
||||||
#if !(MIN_VERSION_base(4,11,0))
|
#if !(MIN_VERSION_base(4,11,0))
|
||||||
import Data.Monoid as Import ((<>))
|
import Data.Monoid as Import ((<>))
|
||||||
|
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-|
|
{-|
|
||||||
|
|
||||||
@ -14,7 +13,6 @@ module Hledger.Web.Main where
|
|||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Foldable (traverse_)
|
|
||||||
import Network.Wai (Application)
|
import Network.Wai (Application)
|
||||||
import Network.Wai.Handler.Warp (runSettings, defaultSettings, setHost, setPort)
|
import Network.Wai.Handler.Warp (runSettings, defaultSettings, setHost, setPort)
|
||||||
import Network.Wai.Handler.Launch (runHostPortUrl)
|
import Network.Wai.Handler.Launch (runHostPortUrl)
|
||||||
@ -42,7 +40,7 @@ hledgerWebMain = do
|
|||||||
|
|
||||||
hledgerWebDev :: IO (Int, Application)
|
hledgerWebDev :: IO (Int, Application)
|
||||||
hledgerWebDev =
|
hledgerWebDev =
|
||||||
withJournalDo' defwebopts (\o j -> defaultDevelApp loader $ makeApplication o j)
|
withJournalDoWeb defwebopts (\o j -> defaultDevelApp loader $ makeApplication o j)
|
||||||
where
|
where
|
||||||
loader =
|
loader =
|
||||||
Yesod.Default.Config.loadConfig
|
Yesod.Default.Config.loadConfig
|
||||||
@ -50,25 +48,24 @@ hledgerWebDev =
|
|||||||
|
|
||||||
runWith :: WebOpts -> IO ()
|
runWith :: WebOpts -> IO ()
|
||||||
runWith opts
|
runWith opts
|
||||||
| "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess
|
| "help" `inRawOpts` rawopts_ (cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess
|
||||||
| "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
|
| "version" `inRawOpts` rawopts_ (cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
|
||||||
| "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
|
| "binary-filename" `inRawOpts` rawopts_ (cliopts_ opts) = putStrLn (binaryfilename progname)
|
||||||
| otherwise = do
|
| otherwise = withJournalDoWeb opts web
|
||||||
requireJournalFileExists =<< (head `fmap` journalFilePathFromOpts (cliopts_ opts)) -- XXX head should be safe for now
|
|
||||||
withJournalDoWeb opts web
|
|
||||||
|
|
||||||
-- | A version of withJournalDo specialised for hledger-web.
|
-- | A version of withJournalDo specialised for hledger-web.
|
||||||
-- Disallows the special - file to avoid some bug,
|
-- Disallows the special - file to avoid some bug,
|
||||||
-- takes WebOpts rather than CliOpts.
|
-- takes WebOpts rather than CliOpts.
|
||||||
withJournalDoWeb :: WebOpts -> (WebOpts -> Journal -> IO ()) -> IO ()
|
withJournalDoWeb :: WebOpts -> (WebOpts -> Journal -> IO a) -> IO a
|
||||||
withJournalDoWeb opts@WebOpts {cliopts_ = copts} cmd = do
|
withJournalDoWeb opts@WebOpts {cliopts_ = copts} cmd = do
|
||||||
journalpaths <- journalFilePathFromOpts copts
|
journalpaths <- journalFilePathFromOpts copts
|
||||||
|
|
||||||
-- https://github.com/simonmichael/hledger/issues/202
|
-- https://github.com/simonmichael/hledger/issues/202
|
||||||
-- -f- gives [Error#yesod-core] <stdin>: hGetContents: illegal operation (handle is closed)
|
-- -f- gives [Error#yesod-core] <stdin>: hGetContents: illegal operation (handle is closed)
|
||||||
-- Also we may try to write to this file. Just disallow -.
|
-- Also we may try to write to this file. Just disallow -.
|
||||||
when (head journalpaths == "-") $ -- always non-empty
|
when ("-" `elem` journalpaths) $ -- always non-empty
|
||||||
error' "hledger-web doesn't support -f -, please specify a file path"
|
error' "hledger-web doesn't support -f -, please specify a file path"
|
||||||
|
mapM_ requireJournalFileExists journalpaths
|
||||||
|
|
||||||
-- keep synced with withJournalDo TODO refactor
|
-- keep synced with withJournalDo TODO refactor
|
||||||
readJournalFiles (inputopts_ copts) journalpaths
|
readJournalFiles (inputopts_ copts) journalpaths
|
||||||
|
@ -57,8 +57,8 @@ webflags =
|
|||||||
"CAP,CAP2"
|
"CAP,CAP2"
|
||||||
"enable these capabilities - comma-separated, possible values are: view, add, manage (default: view,add)"
|
"enable these capabilities - comma-separated, possible values are: view, add, manage (default: view,add)"
|
||||||
, flagReq
|
, flagReq
|
||||||
["capabilities-from-header"]
|
["capabilities-header"]
|
||||||
(\s opts -> Right $ setopt "capabilities-from-header" s opts)
|
(\s opts -> Right $ setopt "capabilities-header" s opts)
|
||||||
"HEADER"
|
"HEADER"
|
||||||
"read enabled capabilities from a HTTP header (e.g. X-Sandstorm-Permissions, disabled by default)"
|
"read enabled capabilities from a HTTP header (e.g. X-Sandstorm-Permissions, disabled by default)"
|
||||||
]
|
]
|
||||||
@ -124,7 +124,7 @@ rawOptsToWebOpts rawopts =
|
|||||||
, base_url_ = b
|
, base_url_ = b
|
||||||
, file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
|
, file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
|
||||||
, capabilities_ = caps
|
, capabilities_ = caps
|
||||||
, capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-from-header" rawopts
|
, capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-header" rawopts
|
||||||
, cliopts_ = cliopts
|
, cliopts_ = cliopts
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
|
@ -7,27 +7,30 @@
|
|||||||
<div#topbar .col-md-8 .col-sm-8 .col-xs-10>
|
<div#topbar .col-md-8 .col-sm-8 .col-xs-10>
|
||||||
<h1>#{takeFileName (journalFilePath j)}
|
<h1>#{takeFileName (journalFilePath j)}
|
||||||
|
|
||||||
<div#sidebar-menu .sidebar-offcanvas.#{sideShowmd}.#{sideShowsm}>
|
$if elem CapView caps
|
||||||
<table .main-menu .table>
|
<div#sidebar-menu .sidebar-offcanvas.#{sideShowmd}.#{sideShowsm}>
|
||||||
^{accounts}
|
<table .main-menu .table>
|
||||||
|
^{accounts}
|
||||||
|
|
||||||
<div#main-content .col-xs-12.#{mainShowmd}.#{mainShowsm}>
|
<div#main-content .col-xs-12.#{mainShowmd}.#{mainShowsm}>
|
||||||
$maybe m <- msg
|
$maybe m <- msg
|
||||||
<div #message .alert.alert-info>#{m}
|
<div #message .alert.alert-info>#{m}
|
||||||
<form#searchform.input-group method=GET>
|
$if elem CapView caps
|
||||||
<input .form-control name=q value=#{q} placeholder="Search"
|
<form#searchform.input-group method=GET>
|
||||||
title="Enter hledger search patterns to filter the data below">
|
<input .form-control name=q value=#{q} placeholder="Search"
|
||||||
<div .input-group-btn>
|
title="Enter hledger search patterns to filter the data below">
|
||||||
$if not (T.null q)
|
<div .input-group-btn>
|
||||||
<a href=@{here} .btn .btn-default title="Clear search terms">
|
$if not (T.null q)
|
||||||
<span .glyphicon .glyphicon-remove-circle>
|
<a href=@{here} .btn .btn-default title="Clear search terms">
|
||||||
<button .btn .btn-default type=submit title="Apply search terms">
|
<span .glyphicon .glyphicon-remove-circle>
|
||||||
<span .glyphicon .glyphicon-search>
|
<button .btn .btn-default type=submit title="Apply search terms">
|
||||||
<a href="@{ManageR}" .btn.btn-default title="Manage journal files">
|
<span .glyphicon .glyphicon-search>
|
||||||
<span .glyphicon .glyphicon-wrench>
|
$if elem CapManage caps
|
||||||
<button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal"
|
<a href="@{ManageR}" .btn.btn-default title="Manage journal files">
|
||||||
title="Show search and general help">
|
<span .glyphicon .glyphicon-wrench>
|
||||||
<span .glyphicon .glyphicon-question-sign>
|
<button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal"
|
||||||
|
title="Show search and general help">
|
||||||
|
<span .glyphicon .glyphicon-question-sign>
|
||||||
^{widget}
|
^{widget}
|
||||||
|
|
||||||
<div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true">
|
<div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true">
|
||||||
|
@ -1,9 +1,10 @@
|
|||||||
<h2>
|
<h2>
|
||||||
#{title'}
|
#{title'}
|
||||||
|
|
||||||
<a #addformlink href="#" role="button" style="cursor:pointer; margin-top:1em;"
|
$if elem CapAdd caps
|
||||||
data-toggle="modal" data-target="#addmodal" title="Add a new transaction to the journal">
|
<a #addformlink href="#" role="button" style="cursor:pointer; margin-top:1em;"
|
||||||
Add a transaction
|
data-toggle="modal" data-target="#addmodal" title="Add a new transaction to the journal">
|
||||||
|
Add a transaction
|
||||||
|
|
||||||
<div .table-responsive>
|
<div .table-responsive>
|
||||||
<table .transactionsreport .table .table-condensed>
|
<table .transactionsreport .table .table-condensed>
|
||||||
@ -34,4 +35,5 @@
|
|||||||
<td .amount style="text-align:right;">
|
<td .amount style="text-align:right;">
|
||||||
^{mixedAmountAsHtml amt}
|
^{mixedAmountAsHtml amt}
|
||||||
|
|
||||||
^{addModal AddR j today}
|
$if elem CapAdd caps
|
||||||
|
^{addModal AddR j today}
|
||||||
|
@ -33,4 +33,5 @@
|
|||||||
<td style="text-align:right;">
|
<td style="text-align:right;">
|
||||||
^{mixedAmountAsHtml bal}
|
^{mixedAmountAsHtml bal}
|
||||||
|
|
||||||
^{addModal AddR j today}
|
$if elem CapAdd caps
|
||||||
|
^{addModal AddR j today}
|
||||||
|
Loading…
Reference in New Issue
Block a user