From 483283ec43a1e177f3ff9dae5a67e2b38c361e36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jakub=20Z=C3=A1rybnick=C3=BD?= Date: Sun, 24 Jun 2018 16:25:22 +0200 Subject: [PATCH] web: Add capabilities guards and conditional widget rendering --- Makefile | 6 +--- hledger-web/Hledger/Web/Foundation.hs | 6 ++-- hledger-web/Hledger/Web/Handler/AddR.hs | 4 ++- hledger-web/Hledger/Web/Handler/EditR.hs | 4 ++- hledger-web/Hledger/Web/Handler/JournalR.hs | 4 +-- hledger-web/Hledger/Web/Handler/RegisterR.hs | 4 ++- hledger-web/Hledger/Web/Handler/UploadR.hs | 4 ++- hledger-web/Hledger/Web/Import.hs | 1 + hledger-web/Hledger/Web/Main.hs | 21 +++++------ hledger-web/Hledger/Web/WebOptions.hs | 6 ++-- hledger-web/templates/default-layout.hamlet | 37 +++++++++++--------- hledger-web/templates/journal.hamlet | 10 +++--- hledger-web/templates/register.hamlet | 3 +- 13 files changed, 59 insertions(+), 51 deletions(-) diff --git a/Makefile b/Makefile index eb573fbf1..8102972e6 100644 --- a/Makefile +++ b/Makefile @@ -134,11 +134,7 @@ SOURCEFILES:= \ hledger-*/Hledger/*hs \ hledger-*/Hledger/*/*hs \ hledger-lib/other/ledger-parse/Ledger/Parser/*hs \ - hledger-web/app/*.hs \ - hledger-web/tests/*.hs \ - hledger-web/Handler/*.hs \ - hledger-web/Hledger/*.hs \ - hledger-web/Settings/*.hs \ + hledger-web/**/*.hs \ HPACKFILES:= \ hledger/*package.yaml \ diff --git a/hledger-web/Hledger/Web/Foundation.hs b/hledger-web/Hledger/Web/Foundation.hs index b32fcbf3c..f49f57c6e 100644 --- a/hledger-web/Hledger/Web/Foundation.hs +++ b/hledger-web/Hledger/Web/Foundation.hs @@ -101,7 +101,7 @@ instance Yesod App where defaultLayout widget = do master <- getYesod here <- fromMaybe RootR <$> getCurrentRoute - VD {j, m, opts, q, qopts} <- getViewData + VD {caps, j, m, opts, q, qopts} <- getViewData msg <- getMessage showSidebar <- shouldShowSidebar hideEmptyAccts <- (== Just "1") . lookup "hideemptyaccts" . reqCookies <$> getRequest @@ -198,8 +198,8 @@ getViewData = do 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 + hs <- fmap (BC.split ',' . snd) . filter ((== h) . fst) . requestHeaders <$> waiRequest + fmap join . for (join 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} diff --git a/hledger-web/Hledger/Web/Handler/AddR.hs b/hledger-web/Hledger/Web/Handler/AddR.hs index 26b3e14bd..2689540af 100644 --- a/hledger-web/Hledger/Web/Handler/AddR.hs +++ b/hledger-web/Hledger/Web/Handler/AddR.hs @@ -20,7 +20,9 @@ getAddR = postAddR postAddR :: Handler () 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 t <- txnTieKnot <$> fromFormSuccess (showForm view enctype) res -- XXX(?) move into balanceTransaction diff --git a/hledger-web/Hledger/Web/Handler/EditR.hs b/hledger-web/Hledger/Web/Handler/EditR.hs index b8d60276c..8c9eed333 100644 --- a/hledger-web/Hledger/Web/Handler/EditR.hs +++ b/hledger-web/Hledger/Web/Handler/EditR.hs @@ -27,7 +27,9 @@ getEditR = postEditR postEditR :: FilePath -> Handler () postEditR f = do - VD {j} <- getViewData + VD {caps, j} <- getViewData + when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") + (f', txt) <- journalFile404 f j ((res, view), enctype) <- runFormPost (editForm f' txt) text <- fromFormSuccess (showForm view enctype) res diff --git a/hledger-web/Hledger/Web/Handler/JournalR.hs b/hledger-web/Hledger/Web/Handler/JournalR.hs index 07a1d3481..fe78de071 100644 --- a/hledger-web/Hledger/Web/Handler/JournalR.hs +++ b/hledger-web/Hledger/Web/Handler/JournalR.hs @@ -15,10 +15,10 @@ import Hledger.Web.Widget.AddForm (addModal) import Hledger.Web.Widget.Common (accountQuery, mixedAmountAsHtml) -- | The formatted journal view, with sidebar. --- XXX like registerReportAsHtml getJournalR :: Handler Html 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 Nothing -> "General Journal" Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)" diff --git a/hledger-web/Hledger/Web/Handler/RegisterR.hs b/hledger-web/Hledger/Web/Handler/RegisterR.hs index bc83640a6..fafe09168 100644 --- a/hledger-web/Hledger/Web/Handler/RegisterR.hs +++ b/hledger-web/Hledger/Web/Handler/RegisterR.hs @@ -22,7 +22,9 @@ import Hledger.Web.Widget.Common (mixedAmountAsHtml) -- | The main journal/account register view, with accounts sidebar. getRegisterR :: Handler Html 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 s1 = if inclsubs then "" else " (excluding subaccounts)" s2 = if m /= Any then ", filtered" else "" diff --git a/hledger-web/Hledger/Web/Handler/UploadR.hs b/hledger-web/Hledger/Web/Handler/UploadR.hs index 2137726d9..c7d02d673 100644 --- a/hledger-web/Hledger/Web/Handler/UploadR.hs +++ b/hledger-web/Hledger/Web/Handler/UploadR.hs @@ -31,7 +31,9 @@ getUploadR = postUploadR postUploadR :: FilePath -> Handler () postUploadR f = do - VD {j} <- getViewData + VD {caps, j} <- getViewData + when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") + (f', _) <- journalFile404 f j ((res, view), enctype) <- runFormPost (uploadForm f') fi <- fromFormSuccess (showForm view enctype) res diff --git a/hledger-web/Hledger/Web/Import.hs b/hledger-web/Hledger/Web/Import.hs index 67cceadcf..ac28e2f84 100644 --- a/hledger-web/Hledger/Web/Import.hs +++ b/hledger-web/Hledger/Web/Import.hs @@ -24,6 +24,7 @@ import Text.Blaze as Import (Markup) import Hledger.Web.Foundation as Import import Hledger.Web.Settings as Import import Hledger.Web.Settings.StaticFiles as Import +import Hledger.Web.WebOptions as Import (Capability(..)) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid as Import ((<>)) diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index 909664b70..e40bda448 100644 --- a/hledger-web/Hledger/Web/Main.hs +++ b/hledger-web/Hledger/Web/Main.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-| @@ -14,7 +13,6 @@ module Hledger.Web.Main where 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) @@ -42,7 +40,7 @@ hledgerWebMain = do hledgerWebDev :: IO (Int, Application) hledgerWebDev = - withJournalDo' defwebopts (\o j -> defaultDevelApp loader $ makeApplication o j) + withJournalDoWeb defwebopts (\o j -> defaultDevelApp loader $ makeApplication o j) where loader = Yesod.Default.Config.loadConfig @@ -50,28 +48,27 @@ hledgerWebDev = runWith :: WebOpts -> IO () runWith opts - | "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess - | "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess - | "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname) - | otherwise = do - requireJournalFileExists =<< (head `fmap` journalFilePathFromOpts (cliopts_ opts)) -- XXX head should be safe for now - withJournalDoWeb opts web + | "help" `inRawOpts` rawopts_ (cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess + | "version" `inRawOpts` rawopts_ (cliopts_ opts) = putStrLn prognameandversion >> exitSuccess + | "binary-filename" `inRawOpts` rawopts_ (cliopts_ opts) = putStrLn (binaryfilename progname) + | otherwise = withJournalDoWeb opts web -- | A version of withJournalDo specialised for hledger-web. -- Disallows the special - file to avoid some bug, -- 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 journalpaths <- journalFilePathFromOpts copts -- https://github.com/simonmichael/hledger/issues/202 -- -f- gives [Error#yesod-core] : hGetContents: illegal operation (handle is closed) -- 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" + mapM_ requireJournalFileExists journalpaths -- keep synced with withJournalDo TODO refactor - readJournalFiles (inputopts_ copts) journalpaths + readJournalFiles (inputopts_ copts) journalpaths >>= mapM (journalTransform copts) >>= either error' (cmd opts) diff --git a/hledger-web/Hledger/Web/WebOptions.hs b/hledger-web/Hledger/Web/WebOptions.hs index 072cd69af..a24f07ae4 100644 --- a/hledger-web/Hledger/Web/WebOptions.hs +++ b/hledger-web/Hledger/Web/WebOptions.hs @@ -57,8 +57,8 @@ webflags = "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) + ["capabilities-header"] + (\s opts -> Right $ setopt "capabilities-header" s opts) "HEADER" "read enabled capabilities from a HTTP header (e.g. X-Sandstorm-Permissions, disabled by default)" ] @@ -124,7 +124,7 @@ rawOptsToWebOpts rawopts = , base_url_ = b , file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts , capabilities_ = caps - , capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-from-header" rawopts + , capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-header" rawopts , cliopts_ = cliopts } where diff --git a/hledger-web/templates/default-layout.hamlet b/hledger-web/templates/default-layout.hamlet index 1667d0973..8f857b724 100644 --- a/hledger-web/templates/default-layout.hamlet +++ b/hledger-web/templates/default-layout.hamlet @@ -7,27 +7,30 @@

#{takeFileName (journalFilePath j)} - - - ^{accounts} +$if elem CapView caps + +
+ ^{accounts} $maybe m <- msg
@@ -34,4 +35,5 @@
^{mixedAmountAsHtml amt} -^{addModal AddR j today} +$if elem CapAdd caps + ^{addModal AddR j today} diff --git a/hledger-web/templates/register.hamlet b/hledger-web/templates/register.hamlet index f71103424..6b3487258 100644 --- a/hledger-web/templates/register.hamlet +++ b/hledger-web/templates/register.hamlet @@ -33,4 +33,5 @@ ^{mixedAmountAsHtml bal} -^{addModal AddR j today} +$if elem CapAdd caps + ^{addModal AddR j today}