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:
parent
c195e35572
commit
95d33f20f6
@ -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."),
|
|
||||||
),
|
),
|
||||||
],
|
],
|
||||||
),
|
),
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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)
|
||||||
|
|||||||
@ -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)"
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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)"
|
||||||
|
|||||||
@ -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')
|
||||||
|
|||||||
@ -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(..))
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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"
|
||||||
|
|||||||
@ -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}
|
||||||
|
|||||||
@ -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}
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user