diff --git a/.sandstorm/launcher.sh b/.sandstorm/launcher.sh index 70b83848b..74ea0a060 100755 --- a/.sandstorm/launcher.sh +++ b/.sandstorm/launcher.sh @@ -29,4 +29,4 @@ set -euo pipefail mkdir -p /var/lib/hledger touch /var/lib/hledger/Ledger cd /var -hledger-web --serve --base-url='' -f /var/lib/hledger/Ledger --port 8000 +hledger-web --capabilities-header=X-Sandstorm-Permissions --serve --base-url='' -f /var/lib/hledger/Ledger --port 8000 diff --git a/.sandstorm/sandstorm-pkgdef.capnp b/.sandstorm/sandstorm-pkgdef.capnp index ce6627ae2..dd088f84c 100644 --- a/.sandstorm/sandstorm-pkgdef.capnp +++ b/.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 = ( - # # Used for integrating permissions and roles into the Sandstorm shell - # # and for sandstorm-http-bridge to pass to your app. - # # Uncomment this block and adjust the permissions and roles to make - # # sense for your app. - # # For more information, see high-level documentation at - # # https://docs.sandstorm.io/en/latest/developing/auth/ - # # and advanced details in the "BridgeConfig" section of - # # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/package.capnp - # viewInfo = ( - # # For details on the viewInfo field, consult "ViewInfo" in - # # 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. - # # - # # IMPORTANT: only ever append to this list! Reordering or removing fields - # # will change behavior and permissions for existing grains! To deprecate a - # # permission, or for more information, see "PermissionDef" in - # # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp - # ( - # name = "editor", - # # Name of the permission, used as an identifier for the permission in cases where string - # # names are preferred. Used in sandstorm-http-bridge's X-Sandstorm-Permissions HTTP header. - # - # title = (defaultText = "editor"), - # # Display name of the permission, e.g. to display in a checklist of permissions - # # that may be assigned when sharing. - # - # description = (defaultText = "grants ability to modify data"), - # # Prose describing what this role means, suitable for a tool tip or similar help text. - # ), - # ], - # roles = [ - # # Roles are logical collections of permissions. For instance, your app may have - # # a "viewer" role and an "editor" role - # ( - # title = (defaultText = "editor"), - # # Name of the role. Shown in the Sandstorm UI to indicate which users have which roles. - # - # permissions = [true], - # # An array indicating which permissions this role carries. - # # It should be the same length as the permissions array in - # # viewInfo, and the order of the lists must match. - # - # verbPhrase = (defaultText = "can make changes to the document"), - # # Brief explanatory text to show in the sharing UI indicating - # # what a user assigned this role will be able to do with the grain. - # - # 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. - # ), - # ( - # title = (defaultText = "viewer"), - # permissions = [false], - # verbPhrase = (defaultText = "can view the document"), - # description = (defaultText = "viewers may view what other users have written."), - # ), - # ], - # ), - # #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. - #), + bridgeConfig = ( + # Used for integrating permissions and roles into the Sandstorm shell + # and for sandstorm-http-bridge to pass to your app. + # Uncomment this block and adjust the permissions and roles to make + # sense for your app. + # For more information, see high-level documentation at + # https://docs.sandstorm.io/en/latest/developing/auth/ + # and advanced details in the "BridgeConfig" section of + # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/package.capnp + viewInfo = ( + # For details on the viewInfo field, consult "ViewInfo" in + # 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. + # + # IMPORTANT: only ever append to this list! Reordering or removing fields + # will change behavior and permissions for existing grains! To deprecate a + # permission, or for more information, see "PermissionDef" in + # https://github.com/sandstorm-io/sandstorm/blob/master/src/sandstorm/grain.capnp + ( + name = "view", + # Name of the permission, used as an identifier for the permission in cases where string + # names are preferred. Used in sandstorm-http-bridge's X-Sandstorm-Permissions HTTP header. + + title = (defaultText = "view"), + # Display name of the permission, e.g. to display in a checklist of permissions + # that may be assigned when sharing. + + description = (defaultText = "grants ability to view the ledger"), + # Prose describing what this role means, suitable for a tool tip or similar help text. + ), + ( + name = "add", + title = (defaultText = "add"), + description = (defaultText = "grants ability to append transactions to the ledger"), + ), + ( + name = "manage", + title = (defaultText = "manage"), + description = (defaultText = "grants ability to modify or replace the entire ledger"), + ), + ], + roles = [ + # Roles are logical collections of permissions. For instance, your app may have + # 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. + + permissions = [true, true, true], + # An array indicating which permissions this role carries. + # It should be the same length as the permissions array in + # viewInfo, and the order of the lists must match. + + 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. + + 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. + ), + ( + title = (defaultText = "editor"), + permissions = [true, true, false], + verbPhrase = (defaultText = "can append new transactions"), + description = (defaultText = "editors can view the ledger or append new transactions to it."), + ), + ( + 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 = ( diff --git a/Makefile b/Makefile index eb573fbf1..8102972e6 100644 --- a/Makefile +++ b/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/tests/*.hs \ - hledger-web/Handler/*.hs \ - hledger-web/Hledger/*.hs \ - hledger-web/Settings/*.hs \ + hledger-web/**/*.hs \ HPACKFILES:= \ hledger/*package.yaml \ diff --git a/hledger-web/Application.hs b/hledger-web/Application.hs deleted file mode 100644 index a8185e4ee..000000000 --- a/hledger-web/Application.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-} -module Application - ( makeApplication - , getApplicationDev - , makeFoundation - ) where - -import Data.Default -import Data.IORef -import Import -import Yesod.Default.Config -import Yesod.Default.Main -import Yesod.Default.Handlers -import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout) -import Network.HTTP.Conduit (newManager) -import Prelude (head) - --- adapt to http-conduit 1.x or 2.x when cabal macros are available, otherwise assume 2.x -#ifdef MIN_VERSION_http_conduit -#if MIN_VERSION_http_conduit(2,0,0) -#define http_conduit_2 -#endif -#else -#define http_conduit_2 -#endif -#ifdef http_conduit_2 -import Network.HTTP.Client (defaultManagerSettings) -#else -import Network.HTTP.Conduit (def) -#endif - --- Import all relevant handler modules here. --- Don't forget to add new modules to your cabal file! -import Handler.RootR -import Handler.JournalR -import Handler.RegisterR -import Handler.SidebarR - -import Hledger.Web.WebOptions (WebOpts(..), defwebopts) -import Hledger.Data (Journal, nulljournal) -import Hledger.Read (readJournalFile) -import Hledger.Utils (error') -import Hledger.Cli.CliOptions (defcliopts, journalFilePathFromOpts) - --- 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 --- comments there for more details. -mkYesodDispatch "App" resourcesApp - --- This function allocates resources (such as a database connection pool), --- performs initialization and creates a WAI application. This is also the --- place to put your migrate statements to have automatic database --- migrations handled by Yesod. -makeApplication :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application -makeApplication opts j conf = do - foundation <- makeFoundation conf opts - writeIORef (appJournal foundation) j - app <- toWaiAppPlain foundation - return $ logWare app - where - logWare | development = logStdoutDev - | serve_ opts = logStdout - | otherwise = id - -makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App -makeFoundation conf opts = do - manager <- newManager -#ifdef http_conduit_2 - defaultManagerSettings -#else - def -#endif - 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 `fmap` readJournalFile def f - defaultDevelApp loader (makeApplication defwebopts j) - where - loader = Yesod.Default.Config.loadConfig (configSettings Development) - { csParseExtra = parseExtra - } diff --git a/hledger-web/Foundation.hs b/hledger-web/Foundation.hs deleted file mode 100644 index 32cb56f69..000000000 --- a/hledger-web/Foundation.hs +++ /dev/null @@ -1,394 +0,0 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-} -{- - -Define the web application's foundation, in the usual Yesod style. -See a default Yesod app's comments for more details of each part. - --} -module Foundation where - -import Prelude -import Data.IORef -import Yesod -import Yesod.Static -import Yesod.Default.Config -#ifndef DEVELOPMENT -import Yesod.Default.Util (addStaticContentExternal) -#endif -import Network.HTTP.Conduit (Manager) --- import qualified Settings -import Settings.StaticFiles -import Settings (staticRoot, widgetFile, Extra (..)) -#ifndef DEVELOPMENT -import Settings (staticDir) -import Text.Jasmine (minifym) -#endif -import Text.Blaze.Html.Renderer.String (renderHtml) -import Text.Hamlet (hamletFile) - -import Hledger.Web.WebOptions -import Hledger.Data.Types --- import Hledger.Web.Settings --- import Hledger.Web.Settings.StaticFiles - --- for addform -import Data.List -import Data.Maybe -import Data.Text as Text (Text,pack,unpack) -import Data.Time.Calendar -#if BLAZE_HTML_0_4 -import Text.Blaze (preEscapedString, Markup) -#else -import Text.Blaze (Markup) -import Text.Blaze.Internal (preEscapedString) -#endif -import Text.JSON -import Hledger.Data.Journal -import Hledger.Query -import Hledger hiding (is) -import Hledger.Cli hiding (version) - - --- | The site argument for your application. This can be a good place to --- keep settings and values requiring initialization before your application --- starts running, such as database connections. Every handler will have --- access to the data present here. -data App = App - { settings :: AppConfig DefaultEnv Extra - , getStatic :: Static -- ^ Settings for static file serving. - , httpManager :: Manager - -- - , appOpts :: WebOpts - , appJournal :: IORef Journal - } - --- Set up i18n messages. See the message folder. -mkMessage "App" "messages" "en" - --- This is where we define all of the routes in our application. For a full --- explanation of the syntax, please see: --- http://www.yesodweb.com/book/handler --- --- This function does three things: --- --- * Creates the route datatype AppRoute. Every valid URL in your --- application can be represented as a value of this type. --- * Creates the associated type: --- type instance Route App = AppRoute --- * Creates the value resourcesApp which contains information on the --- resources declared below. This is used in Handler.hs by the call to --- mkYesodDispatch --- --- What this function does *not* do is create a YesodSite instance for --- App. Creating that instance requires all of the handler functions --- for our application to be in scope. However, the handler functions --- usually require access to the AppRoute datatype. Therefore, we --- split these actions into two functions and place them in separate files. -mkYesodData "App" $(parseRoutesFile "config/routes") - --- | A convenience alias. -type AppRoute = Route App - -#if MIN_VERSION_yesod(1,6,0) -type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget) -#else -type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) -#endif - --- Please see the documentation for the Yesod typeclass. There are a number --- of settings which can be configured by overriding methods here. -instance Yesod App where - approot = ApprootMaster $ appRoot . settings - --- -- Store session data on the client in encrypted cookies, --- -- default session idle timeout is 120 minutes --- makeSessionBackend _ = fmap Just $ defaultClientSessionBackend --- (120 * 60) --- ".hledger-web_client_session_key.aes" - -- don't use session data - makeSessionBackend _ = return Nothing - - defaultLayout widget = do - master <- getYesod - lastmsg <- getMessage - vd@VD{..} <- getViewData - - -- We break up the default layout into two components: - -- default-layout is the contents of the body tag, and - -- default-layout-wrapper is the entire page. Since the final - -- value passed to hamletToRepHtml cannot be a widget, this allows - -- you to use normal widget features in default-layout. - - -- pc <- widgetToPageContent $ do - -- $(widgetFile "normalize") - -- addStylesheet $ StaticR css_bootstrap_css - -- $(widgetFile "default-layout") - -- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") - - pc <- widgetToPageContent $ do - addStylesheet $ StaticR css_bootstrap_min_css - addStylesheet $ StaticR css_bootstrap_datepicker_standalone_min_css - -- load these things early, in HEAD: - toWidgetHead [hamlet| - " "<\\/script>" -- #236 - listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as - numpostings = 4 - postingnums = [1..numpostings] - filepaths = map fst $ jfiles j - postingfields :: ViewData -> Int -> HtmlUrl AppRoute - postingfields _ n = [hamlet| -
-
- -
- -|] - where - acctvar = "account" ++ show n - acctph = "Account " ++ show n - amtvar = "amount" ++ show n - amtph = "Amount " ++ show n - grpvar = "grp" ++ show n - -journalselect :: [FilePath] -> HtmlUrl AppRoute -journalselect journalfilepaths = [hamlet| - -|] - diff --git a/hledger-web/Handler/AddForm.hs b/hledger-web/Handler/AddForm.hs deleted file mode 100644 index 00ed77c1d..000000000 --- a/hledger-web/Handler/AddForm.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, TypeFamilies #-} --- | Add form data & handler. (The layout and js are defined in --- Foundation so that the add form can be in the default layout for --- all views.) - -module Handler.AddForm where - -import Import - -import Control.Monad.State.Strict (evalStateT) -import Data.Either (lefts,rights) -import Data.List (sort) -import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free -import Data.Text (append, pack, unpack) -import qualified Data.Text as T -import Data.Time.Calendar -import Data.Void (Void) -import Text.Megaparsec -import Text.Megaparsec.Char - -import Hledger.Utils -import Hledger.Data -import Hledger.Read -import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout) - - --- Part of the data required from the add form. --- Don't know how to handle the variable posting fields with yesod-form yet. -data AddForm = AddForm - { addFormDate :: Day - , addFormDescription :: Maybe Text -- String - -- , addFormPostings :: [(AccountName, String)] - , addFormJournalFile :: Maybe Text -- FilePath - } - deriving Show - -postAddForm :: Handler Html -postAddForm = do - let showErrors errs = do - -- error $ show errs -- XXX uncomment to prevent redirect for debugging - setMessage [shamlet| - Errors:
- $forall e<-errs - \#{e}
- |] - -- 1. process the fixed fields with yesod-form - - VD{..} <- getViewData - let - validateJournalFile :: Text -> Either FormMessage Text - validateJournalFile f - | unpack f `elem` journalFilePaths j = Right f - | otherwise = Left $ MsgInvalidEntry $ pack "the selected journal file \"" `append` f `append` "\"is unknown" - - validateDate :: Text -> Handler (Either FormMessage Day) - validateDate s = return $ - case fixSmartDateStrEither' today $ T.pack $ strip $ unpack s of - Right d -> Right d - Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e) - - formresult <- runInputPostResult $ AddForm - <$> ireq (checkMMap validateDate (pack . show) textField) "date" - <*> iopt textField "description" - <*> iopt (check validateJournalFile textField) "journal" - - ok <- case formresult of - FormMissing -> showErrors ["there is no form data"::String] >> return False - FormFailure errs -> showErrors errs >> return False - FormSuccess dat -> do - let AddForm{ - addFormDate =date - ,addFormDescription=mdesc - ,addFormJournalFile=mjournalfile - } = dat - desc = maybe "" unpack mdesc - journalfile = maybe (journalFilePath j) unpack mjournalfile - - -- 2. the fixed fields look good; now process the posting fields adhocly, - -- getting either errors or a balanced transaction - - (params,_) <- runRequestBody - let numberedParams s = - reverse $ dropWhile (T.null . snd) $ reverse $ sort - [ (n,v) | (k,v) <- params - , let en = parsewith (paramnamep s) k :: Either (ParseError Char Void) Int - , isRight en - , let Right n = en - ] - where paramnamep s = do {string s; n <- some digitChar; eof; return (read n :: Int)} - acctparams = numberedParams "account" - amtparams = numberedParams "amount" - num = length acctparams - paramErrs | num == 0 = ["at least one posting must be entered"] - | map fst acctparams == [1..num] && - map fst amtparams `elem` [[1..num], [1..num-1]] = [] - | otherwise = ["the posting parameters are malformed"] - eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams - eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams - (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) - (amts', amtErrs) = (rights eamts, map show $ lefts eamts) - amts | length amts' == num = amts' - | otherwise = amts' ++ [missingamt] - errs = if not (null paramErrs) then paramErrs else (acctErrs ++ amtErrs) - etxn | not $ null errs = Left errs - | otherwise = either (\e -> Left [L.head $ lines e]) Right - (balanceTransaction Nothing $ nulltransaction { - tdate=date - ,tdescription=T.pack desc - ,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts] - }) - case etxn of - Left errs -> showErrors errs >> return False - Right t -> do - -- 3. all fields look good and form a balanced transaction; append it to the file - liftIO $ do ensureJournalFileExists journalfile - appendToJournalFileOrStdout journalfile $ - showTransaction $ - txnTieKnot -- XXX move into balanceTransaction - t - setMessage [shamlet|Transaction added.|] - return True - - if ok then redirect JournalR else redirect (JournalR, [("add","1")]) diff --git a/hledger-web/Handler/Common.hs b/hledger-web/Handler/Common.hs deleted file mode 100644 index 3ebd62621..000000000 --- a/hledger-web/Handler/Common.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# LANGUAGE CPP, OverloadedStrings, QuasiQuotes, RecordWildCards #-} --- | Common page components and rendering helpers. --- For global page layout, see Application.hs. - -module Handler.Common where - -import Import - --- import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Calendar -import System.FilePath (takeFileName) -#if BLAZE_HTML_0_4 -import Text.Blaze (preEscapedString) -#else -import Text.Blaze.Internal (preEscapedString) -#endif -import Text.Printf - -import Hledger.Utils -import Hledger.Data -import Hledger.Query -import Hledger.Reports -import Hledger.Cli.CliOptions -import Hledger.Web.WebOptions - -------------------------------------------------------------------------------- --- Common page layout - --- | Standard hledger-web page layout. -#if MIN_VERSION_yesod(1,6,0) -hledgerLayout :: ViewData -> String -> HtmlUrl AppRoute -> HandlerFor App Html -#else -hledgerLayout :: ViewData -> String -> HtmlUrl AppRoute -> HandlerT App IO Html -#endif -hledgerLayout vd title content = do - defaultLayout $ do - setTitle $ toHtml $ title ++ " - hledger-web" - toWidget [hamlet| - ^{topbar vd} - ^{sidebar vd} -
- ^{searchform vd} - ^{content} - |] - where - showmd = if showsidebar vd then "col-md-8" else "col-md-12" :: String - showsm = if showsidebar vd then "col-sm-8" else "col-sm-12" :: String - --- | Global toolbar/heading area. -topbar :: ViewData -> HtmlUrl AppRoute -topbar VD{..} = [hamlet| - -

-