imp:web: access control UX cleanups (fix #834)

Changes:

1. rename the sandstorm "manage" permission to "edit"
(old permission names: view, add, manage;
 new permission names: view, add, edit).

Rationale: "edit" best describes this permission's current powers, to users and to operators.
If we ever added more manager-type features we'd want that to be a new permission,
not a rename of the existing one (which would change the powers of existing users).

2. rename the sandstorm roles for consistency with permissions
(old role names: viewer, editor, manager;
 new role names: viewer, adder, editor)

Rationale: it's needed to avoid confusion.

3. add a new option: --allow=view|add|edit|sandstorm (default: add).
'sandstorm' sets permissions according to the X-Sandstorm-Permissions header.
Drop the --capabilities and --capabilities-header options.

Rationale: it's simpler and more intuitive.

4. replace "capability" with "permission" in ui/docs/code.

Rationale: consistent with the above, more familiar.
This commit is contained in:
Simon Michael 2023-10-23 09:39:13 +01:00
parent c195e35572
commit 95d33f20f6
15 changed files with 120 additions and 113 deletions

View File

@ -54,7 +54,7 @@ const pkgdef :Spk.PackageDefinition = (
#marketBig = (svg = embed "path/to/market-big-300x300.svg"), #marketBig = (svg = embed "path/to/market-big-300x300.svg"),
), ),
website = "http://hledger.org", website = "https://hledger.org",
# This should be the app's main website url. # This should be the app's main website url.
codeUrl = "https://github.com/simonmichael/hledger", codeUrl = "https://github.com/simonmichael/hledger",
@ -204,41 +204,38 @@ const pkgdef :Spk.PackageDefinition = (
description = (defaultText = "grants ability to append transactions to the ledger"), description = (defaultText = "grants ability to append transactions to the ledger"),
), ),
( (
name = "manage", name = "edit",
title = (defaultText = "manage"), title = (defaultText = "edit"),
description = (defaultText = "grants ability to modify or replace the entire ledger"), description = (defaultText = "grants ability to modify transactions and directives or erase the entire ledger"),
), ),
], ],
roles = [ roles = [
# Roles are logical collections of permissions. For instance, your app may have # Roles are logical collections of permissions. For instance, your app may have
# a "viewer" role and an "editor" role # a "viewer" role and an "editor" role
( (
title = (defaultText = "manager"),
# Name of the role. Shown in the Sandstorm UI to indicate which users have which roles. # Name of the role. Shown in the Sandstorm UI to indicate which users have which roles.
title = (defaultText = "viewer"),
permissions = [true, true, true],
# An array indicating which permissions this role carries. # An array indicating which permissions this role carries.
# It should be the same length as the permissions array in # It should be the same length as the permissions array in
# viewInfo, and the order of the lists must match. # viewInfo, and the order of the lists must match.
permissions = [true, false, false],
verbPhrase = (defaultText = "has full access to the ledger"),
# Brief explanatory text to show in the sharing UI indicating # Brief explanatory text to show in the sharing UI indicating
# what a user assigned this role will be able to do with the grain. # what a user assigned this role will be able to do with the grain.
verbPhrase = (defaultText = "can view the ledger"),
description = (defaultText = "managers can modify the ledger in any way."),
# Prose describing what this role means, suitable for a tool tip or similar help text. # Prose describing what this role means, suitable for a tool tip or similar help text.
description = (defaultText = "viewers can only view the ledger."),
),
(
title = (defaultText = "adder"),
permissions = [true, true, false],
verbPhrase = (defaultText = "can append new transactions"),
description = (defaultText = "adders can view the ledger and add new transactions to it."),
), ),
( (
title = (defaultText = "editor"), title = (defaultText = "editor"),
permissions = [true, true, false], permissions = [true, true, true],
verbPhrase = (defaultText = "can append new transactions"), verbPhrase = (defaultText = "has full access to the ledger"),
description = (defaultText = "editors can view the ledger or append new transactions to it."), description = (defaultText = "editors can change or erase transactions and directives."),
),
(
title = (defaultText = "viewer"),
permissions = [true, false, false],
verbPhrase = (defaultText = "can view the ledger"),
description = (defaultText = "viewers can only view the ledger."),
), ),
], ],
), ),

View File

@ -114,7 +114,7 @@ instance Yesod App where
master <- getYesod master <- getYesod
here <- fromMaybe RootR <$> getCurrentRoute here <- fromMaybe RootR <$> getCurrentRoute
VD{opts, j, qparam, q, qopts, caps} <- getViewData VD{opts, j, qparam, q, qopts, perms} <- getViewData
msg <- getMessage msg <- getMessage
showSidebar <- shouldShowSidebar showSidebar <- shouldShowSidebar
@ -198,7 +198,7 @@ data ViewData = VD
, qparam :: Text -- ^ the current "q" request parameter , qparam :: Text -- ^ the current "q" request parameter
, q :: Query -- ^ a query parsed from the q parameter , q :: Query -- ^ a query parsed from the q parameter
, qopts :: [QueryOpt] -- ^ query options parsed from the q parameter , qopts :: [QueryOpt] -- ^ query options parsed from the q parameter
, caps :: [Capability] -- ^ capabilities enabled for this request , perms :: [Permission] -- ^ permissions enabled for this request (by --allow and/or X-Sandstorm-Permissions)
} deriving (Show) } deriving (Show)
instance Show Text.Blaze.Markup where show _ = "<blaze markup>" instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
@ -233,16 +233,19 @@ getViewData = do
-- if either of the above gave an error, display it -- if either of the above gave an error, display it
maybe (pure ()) (setMessage . toHtml) $ mjerr <|> mqerr maybe (pure ()) (setMessage . toHtml) $ mjerr <|> mqerr
-- do some permissions checking -- find out which permissions are enabled
caps <- case capabilitiesHeader_ opts of perms <- case allow_ opts of
Nothing -> return (capabilities_ opts) -- if started with --allow=sandstorm, take permissions from X-Sandstorm-Permissions header
Just h -> do SandstormAccess -> do
let h = "X-Sandstorm-Permissions"
hs <- fmap (BC.split ',' . snd) . filter ((== h) . fst) . requestHeaders <$> waiRequest hs <- fmap (BC.split ',' . snd) . filter ((== h) . fst) . requestHeaders <$> waiRequest
fmap join . for (join hs) $ \x -> case capabilityFromBS x of fmap join . for (join hs) $ \x -> case parsePermission x of
Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml (BC.unpack e)) Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml e)
Right c -> pure [c] Right p -> pure [p]
-- otherwise take them from the access level specified by --allow's access level
cliaccess -> pure $ accessLevelToPermissions cliaccess
return VD{opts, today, j, qparam, q, qopts, caps} return VD{opts, today, j, qparam, q, qopts, perms}
checkServerSideUiEnabled :: Handler () checkServerSideUiEnabled :: Handler ()
checkServerSideUiEnabled = do checkServerSideUiEnabled = do

View File

@ -30,8 +30,8 @@ getAddR = do
postAddR :: Handler () postAddR :: Handler ()
postAddR = do postAddR = do
checkServerSideUiEnabled checkServerSideUiEnabled
VD{caps, j, today} <- getViewData VD{perms, j, today} <- getViewData
when (CapAdd `notElem` caps) (permissionDenied "Missing the 'add' capability") when (AddPermission `notElem` perms) (permissionDenied "Missing the 'add' permission")
((res, view), enctype) <- runFormPost $ addForm j today ((res, view), enctype) <- runFormPost $ addForm j today
case res of case res of
@ -59,8 +59,8 @@ postAddR = do
-- The web form handler above should probably use PUT as well. -- The web form handler above should probably use PUT as well.
putAddR :: Handler RepJson putAddR :: Handler RepJson
putAddR = do putAddR = do
VD{caps, j, opts} <- getViewData VD{perms, j, opts} <- getViewData
when (CapAdd `notElem` caps) (permissionDenied "Missing the 'add' capability") when (AddPermission `notElem` perms) (permissionDenied "Missing the 'add' permission")
(r :: Result Transaction) <- parseCheckJsonBody (r :: Result Transaction) <- parseCheckJsonBody
case r of case r of

View File

@ -31,8 +31,8 @@ getEditR f = do
postEditR :: FilePath -> Handler () postEditR :: FilePath -> Handler ()
postEditR f = do postEditR f = do
checkServerSideUiEnabled checkServerSideUiEnabled
VD {caps, j} <- getViewData VD {perms, j} <- getViewData
when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission")
(f', txt) <- journalFile404 f j (f', txt) <- journalFile404 f j
((res, view), enctype) <- runFormPost (editForm f' txt) ((res, view), enctype) <- runFormPost (editForm f' txt)

View File

@ -20,8 +20,8 @@ import Hledger.Web.Widget.Common
getJournalR :: Handler Html getJournalR :: Handler Html
getJournalR = do getJournalR = do
checkServerSideUiEnabled checkServerSideUiEnabled
VD{caps, j, q, opts, qparam, qopts, today} <- getViewData VD{perms, j, q, opts, qparam, qopts, today} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
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)"

View File

@ -38,17 +38,17 @@ getRootR = do
getManageR :: Handler Html getManageR :: Handler Html
getManageR = do getManageR = do
checkServerSideUiEnabled checkServerSideUiEnabled
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission")
defaultLayout $ do defaultLayout $ do
setTitle "Manage journal" setTitle "Edit journal"
$(widgetFile "manage") $(widgetFile "manage")
getDownloadR :: FilePath -> Handler TypedContent getDownloadR :: FilePath -> Handler TypedContent
getDownloadR f = do getDownloadR f = do
checkServerSideUiEnabled checkServerSideUiEnabled
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission")
(f', txt) <- journalFile404 f j (f', txt) <- journalFile404 f j
addHeader "Content-Disposition" ("attachment; filename=\"" <> T.pack f' <> "\"") addHeader "Content-Disposition" ("attachment; filename=\"" <> T.pack f' <> "\"")
sendResponse ("text/plain" :: ByteString, toContent txt) sendResponse ("text/plain" :: ByteString, toContent txt)
@ -57,50 +57,50 @@ getDownloadR f = do
getVersionR :: Handler TypedContent getVersionR :: Handler TypedContent
getVersionR = do getVersionR = do
VD{caps} <- getViewData VD{perms} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
selectRep $ do selectRep $ do
provideJson $ packageversion provideJson $ packageversion
getAccountnamesR :: Handler TypedContent getAccountnamesR :: Handler TypedContent
getAccountnamesR = do getAccountnamesR = do
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
selectRep $ do selectRep $ do
provideJson $ journalAccountNames j provideJson $ journalAccountNames j
getTransactionsR :: Handler TypedContent getTransactionsR :: Handler TypedContent
getTransactionsR = do getTransactionsR = do
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
selectRep $ do selectRep $ do
provideJson $ jtxns j provideJson $ jtxns j
getPricesR :: Handler TypedContent getPricesR :: Handler TypedContent
getPricesR = do getPricesR = do
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
selectRep $ do selectRep $ do
provideJson $ map priceDirectiveToMarketPrice $ jpricedirectives j provideJson $ map priceDirectiveToMarketPrice $ jpricedirectives j
getCommoditiesR :: Handler TypedContent getCommoditiesR :: Handler TypedContent
getCommoditiesR = do getCommoditiesR = do
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
selectRep $ do selectRep $ do
provideJson $ (M.keys . jinferredcommodities) j provideJson $ (M.keys . jinferredcommodities) j
getAccountsR :: Handler TypedContent getAccountsR :: Handler TypedContent
getAccountsR = do getAccountsR = do
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
selectRep $ do selectRep $ do
provideJson $ flattenAccounts $ mapAccounts (accountSetDeclarationInfo j) $ ledgerRootAccount $ ledgerFromJournal Any j provideJson $ flattenAccounts $ mapAccounts (accountSetDeclarationInfo j) $ ledgerRootAccount $ ledgerFromJournal Any j
getAccounttransactionsR :: Text -> Handler TypedContent getAccounttransactionsR :: Text -> Handler TypedContent
getAccounttransactionsR a = do getAccounttransactionsR a = do
VD{caps, j} <- getViewData VD{perms, j} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
let let
rspec = defreportspec rspec = defreportspec
thisacctq = Acct $ accountNameToAccountRegex a -- includes subs thisacctq = Acct $ accountNameToAccountRegex a -- includes subs

View File

@ -26,8 +26,8 @@ import Hledger.Web.Widget.Common
getRegisterR :: Handler Html getRegisterR :: Handler Html
getRegisterR = do getRegisterR = do
checkServerSideUiEnabled checkServerSideUiEnabled
VD{caps, j, q, opts, qparam, qopts, today} <- getViewData VD{perms, j, q, opts, qparam, qopts, today} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (ViewPermission `notElem` perms) (permissionDenied "Missing the 'view' permission")
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)"

View File

@ -35,8 +35,8 @@ getUploadR f = do
postUploadR :: FilePath -> Handler () postUploadR :: FilePath -> Handler ()
postUploadR f = do postUploadR f = do
checkServerSideUiEnabled checkServerSideUiEnabled
VD {caps, j} <- getViewData VD {perms, j} <- getViewData
when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") when (EditPermission `notElem` perms) (permissionDenied "Missing the 'edit' permission")
(f', _) <- journalFile404 f j (f', _) <- journalFile404 f j
((res, view), enctype) <- runFormPost (uploadForm f') ((res, view), enctype) <- runFormPost (uploadForm f')

View File

@ -23,4 +23,4 @@ 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(..)) import Hledger.Web.WebOptions as Import (Permission(..))

View File

@ -6,17 +6,17 @@ module Hledger.Web.WebOptions where
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Char8 as BC
import Data.ByteString.UTF8 (fromString) import Data.ByteString.UTF8 (fromString)
import Data.CaseInsensitive (CI, mk)
import Data.Default (Default(def)) import Data.Default (Default(def))
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Text (Text) import Data.Text (Text)
import System.Environment (getArgs) import System.Environment (getArgs)
import Network.Wai as WAI import Network.Wai as WAI
import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Cors
import Safe (lastMay)
import Hledger.Cli hiding (packageversion, progname, prognameandversion) import Hledger.Cli hiding (packageversion, progname, prognameandversion)
import Hledger.Web.Settings (defhost, defport, defbaseurl) import Hledger.Web.Settings (defhost, defport, defbaseurl)
import qualified Data.Text as T
-- cf Hledger.Cli.Version -- cf Hledger.Cli.Version
@ -76,15 +76,10 @@ webflags =
"FILEURL" "FILEURL"
"set the static files url (default: BASEURL/static)" "set the static files url (default: BASEURL/static)"
, flagReq , flagReq
["capabilities"] ["allow"]
(\s opts -> Right $ setopt "capabilities" s opts) (\s opts -> Right $ setopt "allow" s opts)
"CAP[,CAP..]" "view|add|edit"
"enable the view, add, and/or manage capabilities (default: view,add)" "set the user's access level for changing data (default: `add`). (There is also `sandstorm`, used when running on Sandstorm.)"
, flagReq
["capabilities-header"]
(\s opts -> Right $ setopt "capabilities-header" s opts)
"HTTPHEADER"
"read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)"
, flagNone , flagNone
["test"] ["test"]
(setboolopt "test") (setboolopt "test")
@ -124,8 +119,7 @@ data WebOpts = WebOpts
, port_ :: !Int , port_ :: !Int
, base_url_ :: !String , base_url_ :: !String
, file_url_ :: !(Maybe String) , file_url_ :: !(Maybe String)
, capabilities_ :: ![Capability] , allow_ :: !AccessLevel
, capabilitiesHeader_ :: !(Maybe (CI ByteString))
, cliopts_ :: !CliOpts , cliopts_ :: !CliOpts
, socket_ :: !(Maybe String) , socket_ :: !(Maybe String)
} deriving (Show) } deriving (Show)
@ -139,8 +133,7 @@ defwebopts = WebOpts
, port_ = def , port_ = def
, base_url_ = "" , base_url_ = ""
, file_url_ = Nothing , file_url_ = Nothing
, capabilities_ = [CapView, CapAdd] , allow_ = AddAccess
, capabilitiesHeader_ = Nothing
, cliopts_ = def , cliopts_ = def
, socket_ = Nothing , socket_ = Nothing
} }
@ -153,15 +146,15 @@ rawOptsToWebOpts rawopts =
cliopts <- rawOptsToCliOpts rawopts cliopts <- rawOptsToCliOpts rawopts
let h = fromMaybe defhost $ maybestringopt "host" rawopts let h = fromMaybe defhost $ maybestringopt "host" rawopts
p = fromMaybe defport $ maybeposintopt "port" rawopts p = fromMaybe defport $ maybeposintopt "port" rawopts
b = b = maybe (defbaseurl h p) stripTrailingSlash $ maybestringopt "base-url" rawopts
maybe (defbaseurl h p) stripTrailingSlash $
maybestringopt "base-url" rawopts
caps' = T.splitOn "," . T.pack =<< listofstringopt "capabilities" rawopts
caps = case traverse capabilityFromText caps' of
Left e -> error' ("Unknown capability: " ++ T.unpack e) -- PARTIAL:
Right [] -> [CapView, CapAdd]
Right xs -> xs
sock = stripTrailingSlash <$> maybestringopt "socket" rawopts sock = stripTrailingSlash <$> maybestringopt "socket" rawopts
access =
case lastMay $ listofstringopt "allow" rawopts of
Nothing -> AddAccess
Just t ->
case parseAccessLevel t of
Right al -> al
Left err -> error' ("Unknown access level: " ++ err) -- PARTIAL:
return return
defwebopts defwebopts
{ serve_ = case sock of { serve_ = case sock of
@ -173,8 +166,7 @@ rawOptsToWebOpts rawopts =
, port_ = p , port_ = p
, base_url_ = b , base_url_ = b
, file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts , file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
, capabilities_ = caps , allow_ = access
, capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-header" rawopts
, cliopts_ = cliopts , cliopts_ = cliopts
, socket_ = sock , socket_ = sock
} }
@ -189,29 +181,45 @@ getHledgerWebOpts = do
args <- fmap (replaceNumericFlags . ensureDebugHasArg) . expandArgsAt =<< getArgs args <- fmap (replaceNumericFlags . ensureDebugHasArg) . expandArgsAt =<< getArgs
rawOptsToWebOpts . either usageError id $ process webmode args rawOptsToWebOpts . either usageError id $ process webmode args
data Capability data Permission
= CapView = ViewPermission -- ^ allow viewing things (read only)
| CapAdd | AddPermission -- ^ allow adding transactions, or more generally allow appending text to input files
| CapManage | EditPermission -- ^ allow editing input files
deriving (Eq, Ord, Bounded, Enum, Show) deriving (Eq, Ord, Bounded, Enum, Show)
capabilityFromText :: Text -> Either Text Capability parsePermission :: ByteString -> Either Text Permission
capabilityFromText "view" = Right CapView parsePermission "view" = Right ViewPermission
capabilityFromText "add" = Right CapAdd parsePermission "add" = Right AddPermission
capabilityFromText "manage" = Right CapManage parsePermission "edit" = Right EditPermission
capabilityFromText x = Left x parsePermission x = Left $ T.pack $ BC.unpack x
capabilityFromBS :: ByteString -> Either ByteString Capability -- | For the --allow option: how much access to allow to hledger-web users ?
capabilityFromBS "view" = Right CapView data AccessLevel =
capabilityFromBS "add" = Right CapAdd ViewAccess -- ^ view permission only
capabilityFromBS "manage" = Right CapManage | AddAccess -- ^ view and add permissions
capabilityFromBS x = Left x | EditAccess -- ^ view, add and edit permissions
| SandstormAccess -- ^ the permissions specified by the X-Sandstorm-Permissions HTTP request header
deriving (Eq, Ord, Bounded, Enum, Show)
parseAccessLevel :: String -> Either String AccessLevel
parseAccessLevel "view" = Right ViewAccess
parseAccessLevel "add" = Right AddAccess
parseAccessLevel "edit" = Right EditAccess
parseAccessLevel "sandstorm" = Right SandstormAccess
parseAccessLevel s = Left $ s <> ", should be one of: view, add, edit, sandstorm"
-- | Convert an --allow access level to the permissions used internally.
-- SandstormAccess generates an empty list, to be filled in later.
accessLevelToPermissions :: AccessLevel -> [Permission]
accessLevelToPermissions ViewAccess = [ViewPermission]
accessLevelToPermissions AddAccess = [ViewPermission, AddPermission]
accessLevelToPermissions EditAccess = [ViewPermission, AddPermission, EditPermission]
accessLevelToPermissions SandstormAccess = [] -- detected from request header
simplePolicyWithOrigin :: Origin -> CorsResourcePolicy simplePolicyWithOrigin :: Origin -> CorsResourcePolicy
simplePolicyWithOrigin origin = simplePolicyWithOrigin origin =
simpleCorsResourcePolicy { corsOrigins = Just ([origin], False) } simpleCorsResourcePolicy { corsOrigins = Just ([origin], False) }
corsPolicyFromString :: String -> WAI.Middleware corsPolicyFromString :: String -> WAI.Middleware
corsPolicyFromString origin = corsPolicyFromString origin =
let let

View File

@ -94,11 +94,9 @@ Can be useful if running behind a reverse web proxy that does path rewriting.
hledger-web normally serves static files itself, but if you wanted to hledger-web normally serves static files itself, but if you wanted to
serve them from another server for efficiency, you would set the url with this. serve them from another server for efficiency, you would set the url with this.
`--capabilities=CAP[,CAP..]` `--allow=view|add|edit`
: enable the view, add, and/or manage capabilities (default: view,add) : set the user's access level for changing data (default: `add`).
(There is also `sandstorm`, used when running on the Sandstorm app platform.)
`--capabilities-header=HTTPHEADER`
: read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)
`--test` `--test`
: run hledger-web's tests and exit. hspec test runner args may follow a --, eg: hledger-web --test -- --help : run hledger-web's tests and exit. hspec test runner args may follow a --, eg: hledger-web --test -- --help

View File

@ -128,6 +128,7 @@ library:
- megaparsec >=7.0.0 && <9.6 - megaparsec >=7.0.0 && <9.6
- mtl >=2.2.1 - mtl >=2.2.1
- network - network
- safe >=0.3.19
- shakespeare >=2.0.2.2 - shakespeare >=2.0.2.2
- template-haskell - template-haskell
- text >=1.2 - text >=1.2

View File

@ -7,7 +7,7 @@
<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)}
$if elem CapView caps $if elem ViewPermission perms
<div#sidebar-menu .sidebar-offcanvas.#{sideShowmd}.#{sideShowsm}> <div#sidebar-menu .sidebar-offcanvas.#{sideShowmd}.#{sideShowsm}>
<table .main-menu .table> <table .main-menu .table>
^{accounts} ^{accounts}
@ -15,7 +15,7 @@ $if elem CapView caps
<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}
$if elem CapView caps $if elem ViewPermission perms
<form#searchform.input-group method=GET> <form#searchform.input-group method=GET>
<input .form-control name=q value=#{qparam} placeholder="Search" <input .form-control name=q value=#{qparam} placeholder="Search"
title="Enter hledger search patterns to filter the data below"> title="Enter hledger search patterns to filter the data below">
@ -25,7 +25,7 @@ $if elem CapView caps
<span .glyphicon .glyphicon-remove-circle> <span .glyphicon .glyphicon-remove-circle>
<button .btn .btn-default type=submit title="Apply search terms"> <button .btn .btn-default type=submit title="Apply search terms">
<span .glyphicon .glyphicon-search> <span .glyphicon .glyphicon-search>
$if elem CapManage caps $if elem EditPermission perms
<a href="@{ManageR}" .btn.btn-default title="Manage journal files"> <a href="@{ManageR}" .btn.btn-default title="Manage journal files">
<span .glyphicon .glyphicon-wrench> <span .glyphicon .glyphicon-wrench>
<button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal" <button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal"

View File

@ -1,7 +1,7 @@
<h2> <h2>
#{title'} #{title'}
$if elem CapAdd caps $if elem AddPermission perms
<a #addformlink href="#" role="button" style="cursor:pointer; margin-top:1em;" <a #addformlink href="#" role="button" style="cursor:pointer; margin-top:1em;"
data-toggle="modal" data-target="#addmodal" title="Add a new transaction to the journal"> data-toggle="modal" data-target="#addmodal" title="Add a new transaction to the journal">
Add a transaction Add a transaction
@ -33,5 +33,5 @@ $if elem CapAdd caps
<td .amount style="text-align:right;"> <td .amount style="text-align:right;">
^{mixedAmountAsHtml amt} ^{mixedAmountAsHtml amt}
$if elem CapAdd caps $if elem AddPermission perms
^{addModal AddR j today} ^{addModal AddR j today}

View File

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