web: Add capabilities guards and conditional widget rendering

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/**/*.hs \
-	hledger-web/tests/*.hs \
-	hledger-web/Handler/*.hs \
-	hledger-web/Hledger/*.hs \
-	hledger-web/Settings/*.hs \
 
 HPACKFILES:= \
 	hledger/*package.yaml \

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
+      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))
         Right c -> pure [c]
   return VD {opts, today, j, q, m, qopts, caps}

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

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

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

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

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

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

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
+  | "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.
 -- 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] <stdin>: 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)
 

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"]
+      ["capabilities-header"]
-      (\s opts -> Right $ setopt "capabilities-from-header" s opts)
+      (\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

hledger-web/templates/default-layout.hamlet

@@ -7,27 +7,30 @@
 <div#topbar .col-md-8 .col-sm-8 .col-xs-10>
   <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}>
   $maybe m <- msg
     <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}
 
 <div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true">

hledger-web/templates/journal.hamlet

@@ -1,9 +1,10 @@
 <h2>
   #{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>
   <table .transactionsreport .table .table-condensed>
@@ -34,4 +35,5 @@
           <td .amount style="text-align:right;">
             ^{mixedAmountAsHtml amt}
 
-^{addModal AddR j today}
+$if elem CapAdd caps
+  ^{addModal AddR j today}

hledger-web/templates/register.hamlet

@@ -33,4 +33,5 @@
           <td style="text-align:right;">
             ^{mixedAmountAsHtml bal}
 
-^{addModal AddR j today}
+$if elem CapAdd caps
+  ^{addModal AddR j today}