From 2ba321885d6aa587634dfafa2a215b991a5adc5e Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Wed, 25 Oct 2023 12:51:08 +0100 Subject: [PATCH] dev:web: refactor permission checking --- hledger-web/Hledger/Web/Foundation.hs | 10 ++++- hledger-web/Hledger/Web/Handler/AddR.hs | 8 ++-- hledger-web/Hledger/Web/Handler/EditR.hs | 4 +- hledger-web/Hledger/Web/Handler/JournalR.hs | 2 +- hledger-web/Hledger/Web/Handler/MiscR.hs | 46 +++++++++----------- hledger-web/Hledger/Web/Handler/RegisterR.hs | 2 +- hledger-web/Hledger/Web/Handler/UploadR.hs | 4 +- hledger-web/Hledger/Web/WebOptions.hs | 5 +++ 8 files changed, 45 insertions(+), 36 deletions(-) diff --git a/hledger-web/Hledger/Web/Foundation.hs b/hledger-web/Hledger/Web/Foundation.hs index c151a9d29..cdbd95c73 100644 --- a/hledger-web/Hledger/Web/Foundation.hs +++ b/hledger-web/Hledger/Web/Foundation.hs @@ -16,7 +16,7 @@ module Hledger.Web.Foundation where import Control.Applicative ((<|>)) -import Control.Monad (join, when) +import Control.Monad (join, when, unless) -- import Control.Monad.Except (runExceptT) -- now re-exported by Hledger import qualified Data.ByteString.Char8 as BC import Data.Traversable (for) @@ -283,3 +283,11 @@ getCurrentJournal jref opts d = do liftIO . writeIORef jref $ filterJournalTransactions depthlessinitialq j' return (j',Nothing) Right (_, False) -> return (j, Nothing) + +-- | In a request handler, check for the given permission +-- and fail with a message if it's not present. +require :: Permission -> Handler () +require p = do + VD{perms} <- getViewData + unless (p `elem` perms) $ permissionDenied $ + "Missing the '" <> T.pack (showPermission p) <> "' permission" diff --git a/hledger-web/Hledger/Web/Handler/AddR.hs b/hledger-web/Hledger/Web/Handler/AddR.hs index f9ed64d98..97cbee897 100644 --- a/hledger-web/Hledger/Web/Handler/AddR.hs +++ b/hledger-web/Hledger/Web/Handler/AddR.hs @@ -30,8 +30,8 @@ getAddR = do postAddR :: Handler () postAddR = do checkServerSideUiEnabled - VD{perms, j, today} <- getViewData - when (AddPermission `notElem` perms) (permissionDenied "Missing the 'add' permission") + VD{j, today} <- getViewData + require AddPermission ((res, view), enctype) <- runFormPost $ addForm j today case res of @@ -59,8 +59,8 @@ postAddR = do -- The web form handler above should probably use PUT as well. putAddR :: Handler RepJson putAddR = do - VD{perms, j, opts} <- getViewData - when (AddPermission `notElem` perms) (permissionDenied "Missing the 'add' permission") + VD{j, opts} <- getViewData + require AddPermission (r :: Result Transaction) <- parseCheckJsonBody case r of diff --git a/hledger-web/Hledger/Web/Handler/EditR.hs b/hledger-web/Hledger/Web/Handler/EditR.hs index 2ec2017dd..caaedeab7 100644 --- a/hledger-web/Hledger/Web/Handler/EditR.hs +++ b/hledger-web/Hledger/Web/Handler/EditR.hs @@ -31,8 +31,8 @@ getEditR f = do postEditR :: FilePath -> Handler () postEditR f = do checkServerSideUiEnabled - VD {perms, j} <- getViewData - when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission") + VD {j} <- getViewData + require EditPermission (f', txt) <- journalFile404 f j ((res, view), enctype) <- runFormPost (editForm f' txt) diff --git a/hledger-web/Hledger/Web/Handler/JournalR.hs b/hledger-web/Hledger/Web/Handler/JournalR.hs index 10419e103..3847217c0 100644 --- a/hledger-web/Hledger/Web/Handler/JournalR.hs +++ b/hledger-web/Hledger/Web/Handler/JournalR.hs @@ -21,7 +21,7 @@ getJournalR :: Handler Html getJournalR = do checkServerSideUiEnabled VD{perms, j, q, opts, qparam, qopts, today} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") + require ViewPermission 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/MiscR.hs b/hledger-web/Hledger/Web/Handler/MiscR.hs index f9919dbdf..e05b3e509 100644 --- a/hledger-web/Hledger/Web/Handler/MiscR.hs +++ b/hledger-web/Hledger/Web/Handler/MiscR.hs @@ -38,8 +38,8 @@ getRootR = do getManageR :: Handler Html getManageR = do checkServerSideUiEnabled - VD{perms, j} <- getViewData - when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission") + VD{j} <- getViewData + require EditPermission defaultLayout $ do setTitle "Edit journal" $(widgetFile "manage") @@ -47,8 +47,8 @@ getManageR = do getDownloadR :: FilePath -> Handler TypedContent getDownloadR f = do checkServerSideUiEnabled - VD{perms, j} <- getViewData - when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission") + VD{j} <- getViewData + require EditPermission (f', txt) <- journalFile404 f j addHeader "Content-Disposition" ("attachment; filename=\"" <> T.pack f' <> "\"") sendResponse ("text/plain" :: ByteString, toContent txt) @@ -57,50 +57,46 @@ getDownloadR f = do getVersionR :: Handler TypedContent getVersionR = do - VD{perms} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") - selectRep $ do - provideJson $ packageversion + require ViewPermission + selectRep $ provideJson $ packageversion getAccountnamesR :: Handler TypedContent getAccountnamesR = do - VD{perms, j} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") - selectRep $ do - provideJson $ journalAccountNames j + VD{j} <- getViewData + require ViewPermission + selectRep $ provideJson $ journalAccountNames j getTransactionsR :: Handler TypedContent getTransactionsR = do - VD{perms, j} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") - selectRep $ do - provideJson $ jtxns j + VD{j} <- getViewData + require ViewPermission + selectRep $ provideJson $ jtxns j getPricesR :: Handler TypedContent getPricesR = do - VD{perms, j} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") - selectRep $ do + VD{j} <- getViewData + require ViewPermission + selectRep $ provideJson $ map priceDirectiveToMarketPrice $ jpricedirectives j getCommoditiesR :: Handler TypedContent getCommoditiesR = do - VD{perms, j} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") + VD{j} <- getViewData + require ViewPermission selectRep $ do provideJson $ (M.keys . jinferredcommodities) j getAccountsR :: Handler TypedContent getAccountsR = do - VD{perms, j} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") + VD{j} <- getViewData + require ViewPermission selectRep $ do provideJson $ flattenAccounts $ mapAccounts (accountSetDeclarationInfo j) $ ledgerRootAccount $ ledgerFromJournal Any j getAccounttransactionsR :: Text -> Handler TypedContent getAccounttransactionsR a = do - VD{perms, j} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") + VD{j} <- getViewData + require ViewPermission let rspec = defreportspec thisacctq = Acct $ accountNameToAccountRegex a -- includes subs diff --git a/hledger-web/Hledger/Web/Handler/RegisterR.hs b/hledger-web/Hledger/Web/Handler/RegisterR.hs index 72ad75082..6d2b4c9fa 100644 --- a/hledger-web/Hledger/Web/Handler/RegisterR.hs +++ b/hledger-web/Hledger/Web/Handler/RegisterR.hs @@ -27,7 +27,7 @@ getRegisterR :: Handler Html getRegisterR = do checkServerSideUiEnabled VD{perms, j, q, opts, qparam, qopts, today} <- getViewData - when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission") + require ViewPermission let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts s1 = if inclsubs then "" else " (excluding subaccounts)" diff --git a/hledger-web/Hledger/Web/Handler/UploadR.hs b/hledger-web/Hledger/Web/Handler/UploadR.hs index af4eca37e..76440a7bb 100644 --- a/hledger-web/Hledger/Web/Handler/UploadR.hs +++ b/hledger-web/Hledger/Web/Handler/UploadR.hs @@ -35,8 +35,8 @@ getUploadR f = do postUploadR :: FilePath -> Handler () postUploadR f = do checkServerSideUiEnabled - VD {perms, j} <- getViewData - when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission") + VD {j} <- getViewData + require EditPermission (f', _) <- journalFile404 f j ((res, view), enctype) <- runFormPost (uploadForm f') diff --git a/hledger-web/Hledger/Web/WebOptions.hs b/hledger-web/Hledger/Web/WebOptions.hs index 0bc3c8a8f..7afe22f10 100644 --- a/hledger-web/Hledger/Web/WebOptions.hs +++ b/hledger-web/Hledger/Web/WebOptions.hs @@ -17,6 +17,7 @@ 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) -- cf Hledger.Cli.Version @@ -193,6 +194,10 @@ parsePermission "add" = Right AddPermission parsePermission "edit" = Right EditPermission parsePermission x = Left $ T.pack $ BC.unpack x +-- | Convert to the lower case permission name. +showPermission :: Permission -> String +showPermission p = map toLower $ reverse $ drop 10 $ reverse $ show p + -- | For the --allow option: how much access to allow to hledger-web users ? data AccessLevel = ViewAccess -- ^ view permission only