dev:web: refactor permission checking

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"

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

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)

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)"

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

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)"

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')

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