web: Add capabilities type, CLI options, and reading them from headers

.sandstorm/sandstorm-pkgdef.capnp

@@ -164,74 +164,90 @@ const pkgdef :Spk.PackageDefinition = (
   # not have been detected as a dependency during `spk dev`. If you list
   # a directory here, its entire contents will be included recursively.
 
-  #bridgeConfig = (
+  bridgeConfig = (
-  #  # Used for integrating permissions and roles into the Sandstorm shell
+    # Used for integrating permissions and roles into the Sandstorm shell
-  #  # and for sandstorm-http-bridge to pass to your app.
+    # and for sandstorm-http-bridge to pass to your app.
-  #  # Uncomment this block and adjust the permissions and roles to make
+    # Uncomment this block and adjust the permissions and roles to make
-  #  # sense for your app.
+    # sense for your app.
-  #  # For more information, see high-level documentation at
+    # For more information, see high-level documentation at
-  #  # https://docs.sandstorm.io/en/latest/developing/auth/
+    # https://docs.sandstorm.io/en/latest/developing/auth/
-  #  # and advanced details in the "BridgeConfig" section of
+    # and advanced details in the "BridgeConfig" section of
-  #  # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/package.capnp
+    # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/package.capnp
-  #  viewInfo = (
+    viewInfo = (
-  #    # For details on the viewInfo field, consult "ViewInfo" in
+      # For details on the viewInfo field, consult "ViewInfo" in
-  #    # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
+      # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
+
+      permissions = [
+      # Permissions which a user may or may not possess.  A user's current
+      # permissions are passed to the app as a comma-separated list of `name`
+      # fields in the X-Sandstorm-Permissions header with each request.
       #
-  #    permissions = [
+      # IMPORTANT: only ever append to this list!  Reordering or removing fields
-  #    # Permissions which a user may or may not possess.  A user's current
+      # will change behavior and permissions for existing grains!  To deprecate a
-  #    # permissions are passed to the app as a comma-separated list of `name`
+      # permission, or for more information, see "PermissionDef" in
-  #    # fields in the X-Sandstorm-Permissions header with each request.
+      # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
-  #    #
+        (
-  #    # IMPORTANT: only ever append to this list!  Reordering or removing fields
+          name = "view",
-  #    # will change behavior and permissions for existing grains!  To deprecate a
+          # Name of the permission, used as an identifier for the permission in cases where string
-  #    # permission, or for more information, see "PermissionDef" in
+          # names are preferred.  Used in sandstorm-http-bridge's X-Sandstorm-Permissions HTTP header.
-  #    # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp
+
-  #      (
+          title = (defaultText = "view"),
-  #        name = "editor",
+          # Display name of the permission, e.g. to display in a checklist of permissions
-  #        # Name of the permission, used as an identifier for the permission in cases where string
+          # that may be assigned when sharing.
-  #        # names are preferred.  Used in sandstorm-http-bridge's X-Sandstorm-Permissions HTTP header.
+
-  #
+          description = (defaultText = "grants ability to view the ledger"),
-  #        title = (defaultText = "editor"),
+          # Prose describing what this role means, suitable for a tool tip or similar help text.
-  #        # Display name of the permission, e.g. to display in a checklist of permissions
+        ),
-  #        # that may be assigned when sharing.
+        (
-  #
+          name = "add",
-  #        description = (defaultText = "grants ability to modify data"),
+          title = (defaultText = "add"),
-  #        # Prose describing what this role means, suitable for a tool tip or similar help text.
+          description = (defaultText = "grants ability to append transactions to the ledger"),
-  #      ),
+        ),
-  #    ],
+        (
-  #    roles = [
+          name = "manage",
-  #      # Roles are logical collections of permissions.  For instance, your app may have
+          title = (defaultText = "manage"),
-  #      # a "viewer" role and an "editor" role
+          description = (defaultText = "grants ability to modify or replace the entire ledger"),
-  #      (
+        ),
-  #        title = (defaultText = "editor"),
+      ],
-  #        # Name of the role.  Shown in the Sandstorm UI to indicate which users have which roles.
+      roles = [
-  #
+        # Roles are logical collections of permissions.  For instance, your app may have
-  #        permissions  = [true],
+        # a "viewer" role and an "editor" role
-  #        # An array indicating which permissions this role carries.
+        (
-  #        # It should be the same length as the permissions array in
+          title = (defaultText = "manager"),
-  #        # viewInfo, and the order of the lists must match.
+          # Name of the role.  Shown in the Sandstorm UI to indicate which users have which roles.
-  #
+
-  #        verbPhrase = (defaultText = "can make changes to the document"),
+          permissions  = [true, true, true],
-  #        # Brief explanatory text to show in the sharing UI indicating
+          # An array indicating which permissions this role carries.
-  #        # what a user assigned this role will be able to do with the grain.
+          # It should be the same length as the permissions array in
-  #
+          # viewInfo, and the order of the lists must match.
-  #        description = (defaultText = "editors may view all site data and change settings."),
+
-  #        # Prose describing what this role means, suitable for a tool tip or similar help text.
+          verbPhrase = (defaultText = "has full access to the ledger"),
-  #      ),
+          # Brief explanatory text to show in the sharing UI indicating
-  #      (
+          # what a user assigned this role will be able to do with the grain.
-  #        title = (defaultText = "viewer"),
+
-  #        permissions  = [false],
+          description = (defaultText = "managers can modify the ledger in any way."),
-  #        verbPhrase = (defaultText = "can view the document"),
+          # Prose describing what this role means, suitable for a tool tip or similar help text.
-  #        description = (defaultText = "viewers may view what other users have written."),
+        ),
-  #      ),
+        (
-  #    ],
+          title = (defaultText = "editor"),
-  #  ),
+          permissions  = [true, true, false],
-  #  #apiPath = "/api",
+          verbPhrase = (defaultText = "can append new transactions"),
-  #  # Apps can export an API to the world.  The API is to be used primarily by Javascript
+          description = (defaultText = "editors can view the ledger or append new transactions to it."),
-  #  # code and native apps, so it can't serve out regular HTML to browsers.  If a request
+        ),
-  #  # comes in to your app's API, sandstorm-http-bridge will prefix the request's path with
+        (
-  #  # this string, if specified.
+          title = (defaultText = "viewer"),
-  #),
+          permissions  = [true, false, false],
+          verbPhrase = (defaultText = "can view the ledger"),
+          description = (defaultText = "viewers can only view the ledger."),
+        ),
+      ],
+    ),
+    #apiPath = "/api",
+    # Apps can export an API to the world.  The API is to be used primarily by Javascript
+    # code and native apps, so it can't serve out regular HTML to browsers.  If a request
+    # comes in to your app's API, sandstorm-http-bridge will prefix the request's path with
+    # this string, if specified.
+  ),
 );
 
 const myCommand :Spk.Manifest.Command = (

hledger-web/app/devel.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE PackageImports #-}
-import "hledger-web" Application (getApplicationDev)
+import "hledger-web" Hledger.Web.Main (hledgerWebDev)
 import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
@@ -9,7 +9,7 @@ import Control.Concurrent (threadDelay)
 main :: IO ()
 main = do
     putStrLn "Starting devel application"
-    (port, app) <- getApplicationDev
+    (port, app) <- hledgerWebDev
     forkIO $ runSettings (setPort port defaultSettings) app
     loop
 

hledger-web/hledger-web.cabal

@@ -156,6 +156,7 @@ library
     , blaze-html
     , blaze-markup
     , bytestring
+    , case-insensitive
     , clientsession
     , cmdargs >=0.10
     , conduit

hledger-web/package.yaml

@@ -103,6 +103,7 @@ library:
   - blaze-html
   - blaze-markup
   - bytestring
+  - case-insensitive
   - clientsession
   - cmdargs >=0.10
   - conduit

hledger-web/src/Application.hs

@@ -6,19 +6,16 @@
 
 module Application
   ( makeApplication
-  , getApplicationDev
   , makeFoundation
   ) where
 
 import Import
 
-import Data.Default (def)
 import Data.IORef (newIORef, writeIORef)
 import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
 import Network.HTTP.Client (defaultManagerSettings)
 import Network.HTTP.Conduit (newManager)
 import Yesod.Default.Config
-import Yesod.Default.Main (defaultDevelApp)
 
 import Handler.AddR (getAddR, postAddR)
 import Handler.Common
@@ -28,10 +25,7 @@ import Handler.UploadR (getUploadR, postUploadR)
 import Handler.JournalR (getJournalR)
 import Handler.RegisterR (getRegisterR)
 import Hledger.Data (Journal, nulljournal)
-import Hledger.Read (readJournalFile)
+import Hledger.Web.WebOptions (WebOpts(serve_))
-import Hledger.Utils (error')
-import Hledger.Cli.CliOptions (defcliopts, journalFilePathFromOpts)
-import Hledger.Web.WebOptions (WebOpts(..), defwebopts)
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -58,15 +52,3 @@ makeFoundation conf opts' = do
     s <- staticSite
     jref <- newIORef nulljournal
     return $ App conf s manager opts' jref
-
--- for yesod devel
--- uses the journal specified by the LEDGER_FILE env var, or ~/.hledger.journal
-getApplicationDev :: IO (Int, Application)
-getApplicationDev = do
-  f <- head `fmap` journalFilePathFromOpts defcliopts -- XXX head should be safe for now
-  j' <- either error' id <$> readJournalFile def f
-  defaultDevelApp loader (makeApplication defwebopts j')
-  where
-    loader = Yesod.Default.Config.loadConfig (configSettings Development)
-        { csParseExtra = parseExtra
-        }

hledger-web/src/Foundation.hs

@@ -16,12 +16,17 @@
 
 module Foundation where
 
+import Control.Monad (join)
+import qualified Data.ByteString.Char8 as BC
+import Data.Traversable (for)
 import Data.IORef (IORef, readIORef, writeIORef)
 import Data.Maybe (fromMaybe)
+import Data.Semigroup ((<>))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Calendar (Day)
 import Network.HTTP.Conduit (Manager)
+import Network.Wai (requestHeaders)
 import System.FilePath (takeFileName)
 import Text.Blaze (Markup)
 import Text.Hamlet (hamletFile)
@@ -172,6 +177,7 @@ data ViewData = VD
   , q     :: Text       -- ^ the current q parameter, the main query expression
   , m     :: Query      -- ^ a query parsed from the q parameter
   , qopts :: [QueryOpt] -- ^ query options parsed from the q parameter
+  , caps  :: [Capability] -- ^ capabilities enabled for this request
   } deriving (Show)
 
 instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
@@ -179,26 +185,25 @@ instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
 -- | Gather data used by handlers and templates in the current request.
 getViewData :: Handler ViewData
 getViewData = do
-  y <- getYesod
+  App {appOpts = opts, appJournal} <- getYesod
   today <- liftIO getCurrentDay
-  let copts = cliopts_ (appOpts y)
+  let copts = cliopts_ opts
   (j, merr) <-
     getCurrentJournal
-      (appJournal y)
+      appJournal
       copts {reportopts_ = (reportopts_ copts) {no_elide_ = True}}
       today
   maybe (pure ()) (setMessage . toHtml) merr
   q <- fromMaybe "" <$> lookupGetParam "q"
-  let (querymatcher, queryopts) = parseQuery today q
+  let (m, qopts) = parseQuery today q
-  return
+  caps <- case capabilitiesHeader_ opts of
-    VD
+    Nothing -> return (capabilities_ opts)
-    { opts = appOpts y
+    Just h -> do
-    , today = today
+      hs <- fmap snd . filter ((== h) . fst) . requestHeaders <$> waiRequest
-    , j = j
+      fmap join . for hs $ \x -> case capabilityFromBS x of
-    , q = q
+        Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml (BC.unpack e))
-    , m = querymatcher
+        Right c -> pure [c]
-    , qopts = queryopts
+  return VD {opts, today, j, q, m, qopts, caps}
-    }
 
 -- | Find out if the sidebar should be visible. Show it, unless there is a
 -- showsidebar cookie set to "0", or a ?sidebar=0 query parameter.

hledger-web/src/Hledger/Web/Main.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-|
 
 hledger-web - a hledger add-on providing a web interface.
@@ -9,23 +11,26 @@ Released under GPL version 3 or later.
 
 module Hledger.Web.Main where
 
-import Control.Monad ((<=<), when)
+import Control.Monad (when)
-import Data.Default (def)
 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)
 import Prelude hiding (putStrLn)
 import System.Exit (exitSuccess)
 import System.IO (hFlush, stdout)
 import Text.Printf (printf)
-import Yesod.Default.Config (AppConfig(..), DefaultEnv(Development))
+import Yesod.Default.Config
+import Yesod.Default.Main (defaultDevelApp)
 
 import Application (makeApplication)
-import Settings (Extra(..))
+import Settings (Extra(..), parseExtra)
 
 import Hledger
 import Hledger.Cli hiding (progname,prognameandversion)
+import Hledger.Cli.Utils (journalTransform)
 import Hledger.Utils.UTF8IOCompat (putStrLn)
 import Hledger.Web.WebOptions
 
@@ -36,6 +41,14 @@ hledgerWebMain = do
   when (debug_ (cliopts_ opts) > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)
   runWith opts
 
+hledgerWebDev :: IO (Int, Application)
+hledgerWebDev =
+  withJournalDo' defwebopts (\o j -> defaultDevelApp loader $ makeApplication o j)
+  where
+    loader =
+      Yesod.Default.Config.loadConfig
+        (configSettings Development) {csParseExtra = parseExtra}
+
 runWith :: WebOpts -> IO ()
 runWith opts
   | "help"            `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess
@@ -86,10 +99,7 @@ web opts j = do
     then do
       putStrLn "Press ctrl-c to quit"
       hFlush stdout
-      let warpsettings =
+      let warpsettings = setHost (fromString h) (setPort p defaultSettings)
-            setHost (fromString h) $
-            setPort p $
-            defaultSettings
       Network.Wai.Handler.Warp.runSettings warpsettings app
     else do
       putStrLn "Starting web browser..."

hledger-web/src/Hledger/Web/WebOptions.hs

@@ -1,8 +1,15 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Hledger.Web.WebOptions where
 
-import Data.Default (def)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BC
+import Data.CaseInsensitive (CI, mk)
+import Control.Monad (join)
+import Data.Default (Default(def))
 import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text (Text)
 import System.Environment (getArgs)
 
 import Settings (defhost, defport, defbaseurl)
@@ -19,81 +26,137 @@ version = ""
 prognameandversion :: String
 prognameandversion = progname ++ " " ++ version :: String
 
-webflags :: [Flag [([Char], [Char])]]
+webflags :: [Flag [(String, String)]]
-webflags = [
+webflags =
-  flagNone ["serve","server"]   (setboolopt "serve") ("serve and log requests, don't browse or auto-exit")
+  [ flagNone
- ,flagReq  ["host"]     (\s opts -> Right $ setopt "host" s opts) "IPADDR" ("listen on this IP address (default: "++defhost++")")
+      ["serve", "server"]
- ,flagReq  ["port"]     (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this TCP port (default: "++show defport++")")
+      (setboolopt "serve")
- ,flagReq  ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "BASEURL" ("set the base url (default: http://IPADDR:PORT)")
+      "serve and log requests, don't browse or auto-exit"
- ,flagReq  ["file-url"] (\s opts -> Right $ setopt "file-url" s opts) "FILEURL" ("set the static files url (default: BASEURL/static)")
+  , flagReq
+      ["host"]
+      (\s opts -> Right $ setopt "host" s opts)
+      "IPADDR"
+      ("listen on this IP address (default: " ++ defhost ++ ")")
+  , flagReq
+      ["port"]
+      (\s opts -> Right $ setopt "port" s opts)
+      "PORT"
+      ("listen on this TCP port (default: " ++ show defport ++ ")")
+  , flagReq
+      ["base-url"]
+      (\s opts -> Right $ setopt "base-url" s opts)
+      "BASEURL"
+      "set the base url (default: http://IPADDR:PORT)"
+  , flagReq
+      ["file-url"]
+      (\s opts -> Right $ setopt "file-url" s opts)
+      "FILEURL"
+      "set the static files url (default: BASEURL/static)"
+  , flagReq
+      ["capabilities"]
+      (\s opts -> Right $ setopt "capabilities" s opts)
+      "CAP,CAP2"
+      "enable these capabilities - comma-separated, possible values are: view, add, manage (default: view,add)"
+  , flagReq
+      ["capabilities-from-header"]
+      (\s opts -> Right $ setopt "capabilities-from-header" s opts)
+      "HEADER"
+      "read enabled capabilities from a HTTP header (e.g. X-Sandstorm-Permissions, disabled by default)"
   ]
 
-webmode :: Mode [([Char], [Char])]
+webmode :: Mode [(String, String)]
-webmode =  (mode "hledger-web" [("command","web")]
+webmode =
+  (mode
+     "hledger-web"
+     [("command", "web")]
      "start serving the hledger web interface"
-            (argsFlag "[PATTERNS]") []){
+     (argsFlag "[PATTERNS]")
-              modeGroupFlags = Group {
+     [])
-                                groupUnnamed = webflags
+  { modeGroupFlags =
-                               ,groupHidden = [flagNone ["binary-filename"] (setboolopt "binary-filename") "show the download filename for this executable, and exit"]
+      Group
+      { groupUnnamed = webflags
+      , groupHidden =
+          [ flagNone
+              ["binary-filename"]
+              (setboolopt "binary-filename")
+              "show the download filename for this executable, and exit"
+          ]
       , groupNamed = [generalflagsgroup1]
       }
-             ,modeHelpSuffix=[
+  , modeHelpSuffix = []
-                  -- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."
-                 ]
   }
 
 -- hledger-web options, used in hledger-web and above
-data WebOpts = WebOpts {
+data WebOpts = WebOpts
-     serve_    :: Bool
+  { serve_ :: Bool
   , host_ :: String
   , port_ :: Int
   , base_url_ :: String
   , file_url_ :: Maybe String
+  , capabilities_ :: [Capability]
+  , capabilitiesHeader_ :: Maybe (CI ByteString)
   , cliopts_ :: CliOpts
   } deriving (Show)
 
 defwebopts :: WebOpts
-defwebopts = WebOpts
+defwebopts = WebOpts def def def def def [CapView, CapAdd] Nothing def
-    def
-    def
-    def
-    def
-    def
-    def
 
--- instance Default WebOpts where def = defwebopts
+instance Default WebOpts where def = defwebopts
 
 rawOptsToWebOpts :: RawOpts -> IO WebOpts
-rawOptsToWebOpts rawopts = checkWebOpts <$> do
+rawOptsToWebOpts rawopts =
+  checkWebOpts <$> do
     cliopts <- rawOptsToCliOpts rawopts
-  let
+    let h = fromMaybe defhost $ maybestringopt "host" rawopts
-    h = fromMaybe defhost $ maybestringopt "host" rawopts
         p = fromMaybe defport $ maybeintopt "port" rawopts
-    b = maybe (defbaseurl h p) stripTrailingSlash $ maybestringopt "base-url" rawopts
+        b =
-  return defwebopts {
+          maybe (defbaseurl h p) stripTrailingSlash $
-              serve_ = boolopt "serve" rawopts
+          maybestringopt "base-url" rawopts
+        caps' = join $ T.splitOn "," . T.pack <$> listofstringopt "capabilities" rawopts
+        caps = case traverse capabilityFromText caps' of
+          Left e -> error' ("Unknown capability: " ++ T.unpack e)
+          Right [] -> [CapView, CapAdd]
+          Right xs -> xs
+    return
+      defwebopts
+      { serve_ = boolopt "serve" rawopts
       , host_ = h
       , port_ = p
       , base_url_ = b
       , file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
+      , capabilities_ = caps
+      , capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-from-header" rawopts
       , cliopts_ = cliopts
       }
   where
     stripTrailingSlash = reverse . dropWhile (== '/') . reverse -- yesod don't like it
 
 checkWebOpts :: WebOpts -> WebOpts
-checkWebOpts wopts =
+checkWebOpts wopts = do
-  either usageError (const wopts) $ do
   let h = host_ wopts
-    if any (not . (`elem` ".0123456789")) h
+  if any (`notElem` (".0123456789" :: String)) h
-    then Left $ "--host requires an IP address, not "++show h
+    then usageError $ "--host requires an IP address, not " ++ show h
-    else Right ()
+    else wopts
 
 getHledgerWebOpts :: IO WebOpts
---getHledgerWebOpts = processArgs webmode >>= return . decodeRawOpts >>= rawOptsToWebOpts
 getHledgerWebOpts = do
-  args <- getArgs >>= expandArgsAt
+  args <- fmap replaceNumericFlags . expandArgsAt =<< getArgs
-  let args' = replaceNumericFlags args 
+  rawOptsToWebOpts . decodeRawOpts . either usageError id $ process webmode args
-  let cmdargopts = either usageError id $ process webmode args'
-  rawOptsToWebOpts $ decodeRawOpts cmdargopts 
 
+data Capability
+  = CapView
+  | CapAdd
+  | CapManage
+  deriving (Eq, Ord, Bounded, Enum, Show)
+
+capabilityFromText :: Text -> Either Text Capability
+capabilityFromText "view" = Right CapView
+capabilityFromText "add" = Right CapAdd
+capabilityFromText "manage" = Right CapManage
+capabilityFromText x = Left x
+
+capabilityFromBS :: ByteString -> Either ByteString Capability
+capabilityFromBS "view" = Right CapView
+capabilityFromBS "add" = Right CapAdd
+capabilityFromBS "manage" = Right CapManage
+capabilityFromBS x = Left x