hledger-web-1.50.3/Hledger/0000755000000000000000000000000015054061121013520 5ustar0000000000000000hledger-web-1.50.3/Hledger/Web/0000755000000000000000000000000015107137141014242 5ustar0000000000000000hledger-web-1.50.3/Hledger/Web/Handler/0000755000000000000000000000000015107137141015617 5ustar0000000000000000hledger-web-1.50.3/Hledger/Web/Settings/0000755000000000000000000000000015054061121016035 5ustar0000000000000000hledger-web-1.50.3/Hledger/Web/Widget/0000755000000000000000000000000015107174442015472 5ustar0000000000000000hledger-web-1.50.3/app/0000755000000000000000000000000015054060534012735 5ustar0000000000000000hledger-web-1.50.3/config/0000755000000000000000000000000015106732206013422 5ustar0000000000000000hledger-web-1.50.3/static/0000755000000000000000000000000015106732206013444 5ustar0000000000000000hledger-web-1.50.3/static/css/0000755000000000000000000000000015022704461014233 5ustar0000000000000000hledger-web-1.50.3/static/fonts/0000755000000000000000000000000015022704461014574 5ustar0000000000000000hledger-web-1.50.3/static/js/0000755000000000000000000000000015022704461014057 5ustar0000000000000000hledger-web-1.50.3/templates/0000755000000000000000000000000015106732206014153 5ustar0000000000000000hledger-web-1.50.3/test/0000755000000000000000000000000015054060534013134 5ustar0000000000000000hledger-web-1.50.3/Hledger/Web.hs0000644000000000000000000000106415054061121014572 0ustar0000000000000000{-| This is the root module of the @hledger-web@ package, providing hledger's web user interface and JSON API. The main function and command-line options are exported. == See also: - hledger-lib:Hledger - hledger:Hledger.Cli - [The README files](https://github.com/search?q=repo%3Asimonmichael%2Fhledger+path%3A**%2FREADME*&type=code&ref=advsearch) - [The high-level developer docs](https://hledger.org/dev.html) -} module Hledger.Web ( module Hledger.Web.Main, module Hledger.Web.WebOptions ) where import Hledger.Web.WebOptions import Hledger.Web.Main hledger-web-1.50.3/Hledger/Web/Main.hs0000644000000000000000000001525215107137141015467 0ustar0000000000000000{-| hledger-web - a basic but robust web UI and JSON API server for hledger. SPDX-License-Identifier: GPL-3.0-or-later Copyright (c) 2007-2025 (each year in this range) Simon Michael and contributors. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . -} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Hledger.Web.Main where import Control.Exception (bracket) #if MIN_VERSION_base(4,20,0) import Control.Exception.Backtrace (setBacktraceMechanismState, BacktraceMechanism(..)) #endif import Control.Monad (when) import Data.String (fromString) import Data.Text qualified as T import Network.Socket import Network.Wai (Application) import Network.Wai.Handler.Warp (runSettings, runSettingsSocket, defaultSettings, setHost, setPort) import Network.Wai.Handler.Launch (runHostPortFullUrl) import System.Directory (removeFile) import System.Environment ( getArgs, withArgs ) import System.IO (hFlush, stdout) import System.PosixCompat.Files (getFileStatus, isSocket) import Text.Printf (printf) import Yesod.Default.Config import Yesod.Default.Main (defaultDevelApp) import Hledger import Hledger.Cli hiding (progname,prognameandversion) import Hledger.Web.Application (makeApplication) import Hledger.Web.Settings (Extra(..), parseExtra) import Hledger.Web.Test (hledgerWebTest) import Hledger.Web.WebOptions -- Run in fast reloading mode for yesod devel. hledgerWebDev :: IO (Int, Application) hledgerWebDev = withJournal (cliopts_ defwebopts) (defaultDevelApp loader . makeApplication defwebopts) where loader = Yesod.Default.Config.loadConfig (configSettings Development) {csParseExtra = parseExtra} -- Run normally. hledgerWebMain :: IO () hledgerWebMain = handleExit $ withGhcDebug' $ do when (ghcDebugMode == GDPauseAtStart) $ ghcDebugPause' #if MIN_VERSION_base(4,20,0) -- Control ghc 9.10+'s stack traces. -- CostCentreBacktrace - collect cost-centre stack backtraces (only available when built with profiling) -- HasCallStackBacktrace - collect HasCallStack backtraces -- ExecutionBacktrace - collect backtraces from native execution stack unwinding -- IPEBacktrace - collect backtraces from Info Table Provenance Entries #ifdef DEBUG setBacktraceMechanismState HasCallStackBacktrace True #else setBacktraceMechanismState HasCallStackBacktrace False #endif #endif -- try to encourage user's $PAGER to properly display ANSI (in command line help) usecolor <- useColorOnStdout when usecolor setupPager wopts@WebOpts{cliopts_=copts@CliOpts{debug_, rawopts_}} <- getHledgerWebOpts when (debug_ > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show wopts) if | boolopt "help" rawopts_ -> runPager $ showModeUsage webmode ++ "\n" | boolopt "tldr" rawopts_ -> runTldrForPage "hledger-web" | boolopt "info" rawopts_ -> runInfoForTopic "hledger-web" Nothing | boolopt "man" rawopts_ -> runManForTopic "hledger-web" Nothing | boolopt "version" rawopts_ -> putStrLn prognameandversion -- boolopt "binary-filename" rawopts_ -> putStrLn (binaryfilename progname) | boolopt "test" rawopts_ -> do -- remove --test and --, leaving other args for hspec (`withArgs` hledgerWebTest) . filter (`notElem` ["--test","--"]) =<< getArgs | otherwise -> withJournal copts (web wopts) when (ghcDebugMode == GDPauseAtEnd) $ ghcDebugPause' -- | The hledger web command. web :: WebOpts -> Journal -> IO () web opts j = do let depthlessinitialq = filterQuery (not . queryIsDepth) . _rsQuery . reportspec_ $ cliopts_ opts j' = filterJournalTransactions depthlessinitialq j h = host_ opts p = port_ opts u = base_url_ opts staticRoot = T.pack <$> file_url_ opts -- XXX not used #2139 appconfig = AppConfig{appEnv = Development ,appHost = fromString h ,appPort = p ,appRoot = T.pack u ,appExtra = Extra "" Nothing staticRoot } app <- makeApplication opts j' appconfig -- show configuration let services | server_mode_ opts == ServeJson = "json API" | otherwise = "web UI and json API" prettyip ip | ip == "127.0.0.1" = ip ++ " (local access)" | ip == "0.0.0.0" = ip ++ " (all interfaces)" | otherwise = ip listenat = case socket_ opts of Just s -> printf "socket %s" s Nothing -> printf "IP address %s, port %d" (prettyip h) p printf "Serving %s at %s\nwith base url %s\n" (services::String) (listenat::String) u case file_url_ opts of Just fu -> printf "and static files base url %s\n" fu Nothing -> pure () -- start server and maybe browser if server_mode_ opts == ServeBrowse then do putStrLn "This server will exit after 2m with no browser windows open (or press ctrl-c)" putStrLn "Opening web browser..." hFlush stdout -- exits after 2m of inactivity (hardcoded) Network.Wai.Handler.Launch.runHostPortFullUrl h p u app else do putStrLn "Press ctrl-c to quit" hFlush stdout let warpsettings = setHost (fromString h) (setPort p defaultSettings) case socket_ opts of Just s -> do if isUnixDomainSocketAvailable then bracket (do sock <- socket AF_UNIX Stream 0 setSocketOption sock ReuseAddr 1 bind sock $ SockAddrUnix s listen sock maxListenQueue return sock ) (\_ -> do sockstat <- getFileStatus s when (isSocket sockstat) $ removeFile s ) (\sock -> Network.Wai.Handler.Warp.runSettingsSocket warpsettings sock app) else error' $ unlines ["Unix domain sockets are not available on your operating system." ,"Please try again without --socket." ] Nothing -> Network.Wai.Handler.Warp.runSettings warpsettings app hledger-web-1.50.3/Hledger/Web/WebOptions.hs0000644000000000000000000002232215107137141016670 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} module Hledger.Web.WebOptions where import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.ByteString.UTF8 (fromString) import Data.Default (Default(def)) import Data.Maybe (fromMaybe) import Data.Text (Text) import GitHash (tGitInfoCwdTry) import System.Environment (getArgs) import Network.Wai as WAI import Network.Wai.Middleware.Cors import Safe (lastMay) import Hledger.Cli hiding (packageversion, progname, prognameandversion) import Hledger.Web.Settings (defhost, defport, defbaseurl) import Data.Text qualified as T import Data.Char (toLower) import Data.List (isPrefixOf) import Data.Either (fromRight) -- cf Hledger.Cli.Version packageversion :: PackageVersionString packageversion = #ifdef VERSION VERSION #else "" #endif -- | The name of this program's executable. progname :: ProgramName progname = "hledger-web" -- | Generate the version string for this program. -- The template haskell call is here rather than in Hledger.Cli.Version to avoid wasteful recompilation. prognameandversion :: String prognameandversion = versionStringWith $$tGitInfoCwdTry #ifdef GHCDEBUG True #else False #endif progname packageversion binaryinfo :: HledgerBinaryInfo binaryinfo = fromRight nullbinaryinfo $ parseHledgerVersion prognameandversion webflags :: [Flag RawOpts] webflags = [ flagNone ["serve-browse"] (setboolopt "serve-browse") (serveprefix ++ "serve the web UI and JSON API, and open a browser, and exit if inactive for 2m (default)") , flagNone ["serve"] (setboolopt "serve") (serveprefix ++ "just serve the web UI and JSON API") , flagNone ["serve-api"] (setboolopt "serve-api") (serveprefix ++ "just serve the JSON API") , flagReq ["allow"] (\s opts -> Right $ setopt "allow" s opts) "view|add|edit" "set the user's access level for changing data (default: `add`). It also accepts `sandstorm` for use on that platform (reads permissions from the `X-Sandstorm-Permissions` request header)." , flagReq ["cors"] (\s opts -> Right $ setopt "cors" s opts) "ORIGIN" ("allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin") , 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 ["socket"] (\s opts -> Right $ setopt "socket" s opts) "SOCKET" "listen on the given unix socket instead of an IP address and port (only on unix)" , flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "BASEURL" "set the base url (default: http://IPADDR:PORT)" -- XXX #2139 -- , flagReq -- ["file-url"] -- (\s opts -> Right $ setopt "file-url" s opts) -- "FILEURL" -- "set a different base url for static files (default: `BASEURL/static/`)" , flagNone ["test"] (setboolopt "test") "run hledger-web's tests and exit. hspec test runner args may follow a --, eg: hledger-web --test -- --help" ] where serveprefix = "server mode: " webmode :: Mode RawOpts webmode = (mode "hledger-web" (setopt "command" "web" def) "start serving the hledger web interface" (argsFlag "[PATTERNS]") []) { modeGroupFlags = Group { groupUnnamed = webflags , groupHidden = hiddenflags ++ [flagNone ["server"] (setboolopt "serve") "old flag, use --serve instead"] , groupNamed = mkgeneralflagsgroups1 helpflags } , modeHelpSuffix = [] } data ServerMode = ServeBrowse | Serve | ServeJson deriving (Show, Eq) -- hledger-web options, used in hledger-web and above data WebOpts = WebOpts { server_mode_ :: !ServerMode , cors_ :: !(Maybe String) , host_ :: !String , port_ :: !Int , base_url_ :: !String , file_url_ :: !(Maybe String) , allow_ :: !AccessLevel , cliopts_ :: !CliOpts , socket_ :: !(Maybe String) } deriving (Show) defwebopts :: WebOpts defwebopts = WebOpts { server_mode_ = ServeBrowse , cors_ = Nothing , host_ = "" , port_ = def , base_url_ = "" , file_url_ = Nothing , allow_ = AddAccess , cliopts_ = def , socket_ = Nothing } instance Default WebOpts where def = defwebopts rawOptsToWebOpts :: RawOpts -> IO WebOpts rawOptsToWebOpts rawopts = checkWebOpts <$> do cliopts <- rawOptsToCliOpts rawopts let h = fromMaybe defhost $ maybestringopt "host" rawopts p = fromMaybe defport $ maybeposintopt "port" rawopts -- Always set a base-url, constructing it from host and port if not specified. -- This will be used when opening a web browser, eg. -- App.hs approot will use it if it was specified by --base-url, -- otherwise it will infer a better one from the request, which browsers prefer. b = maybe (defbaseurl h p) stripTrailingSlash $ maybestringopt "base-url" 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 defwebopts { server_mode_ = servermodeopt rawopts , cors_ = maybestringopt "cors" rawopts , host_ = h , port_ = p , base_url_ = b , file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts , allow_ = access , cliopts_ = cliopts , socket_ = sock } where stripTrailingSlash = reverse . dropWhile (== '/') . reverse -- yesod don't like it servermodeopt :: RawOpts -> ServerMode servermodeopt = fromMaybe ServeBrowse . choiceopt parse where parse = \case "serve-browse" -> Just ServeBrowse "serve" -> Just Serve "serve-api" -> Just ServeJson _ -> Nothing checkWebOpts :: WebOpts -> WebOpts checkWebOpts wopts@WebOpts{..} | not $ null base_url_ || "http://" `isPrefixOf` base_url_ || "https://" `isPrefixOf` base_url_ = error' "please begin the --base-url value with http:// or https://" | otherwise = wopts getHledgerWebOpts :: IO WebOpts getHledgerWebOpts = do args <- fmap (ensureDebugFlagHasVal . replaceNumericFlags) . expandArgsAt =<< getArgs rawOptsToWebOpts . either usageError id $ process webmode args data Permission = ViewPermission -- ^ allow viewing things (read only) | AddPermission -- ^ allow adding transactions, or more generally allow appending text to input files | EditPermission -- ^ allow editing input files deriving (Eq, Ord, Bounded, Enum, Show) parsePermission :: ByteString -> Either Text Permission parsePermission "view" = Right ViewPermission parsePermission "add" = Right AddPermission parsePermission "edit" = Right EditPermission parsePermission x = Left $ T.pack $ BC.unpack x -- | Convert to the lower case permission name. showPermission :: Permission -> String showPermission p = map toLower $ reverse $ drop 10 $ reverse $ show p -- | For the --allow option: how much access to allow to hledger-web users ? data AccessLevel = ViewAccess -- ^ view permission only | AddAccess -- ^ view and add permissions | 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 = simpleCorsResourcePolicy { corsOrigins = Just ([origin], False) } corsPolicyFromString :: String -> WAI.Middleware corsPolicyFromString origin = let policy = case origin of "*" -> simpleCorsResourcePolicy url -> simplePolicyWithOrigin $ fromString url in cors (const $ Just policy) corsPolicy :: WebOpts -> (Application -> Application) corsPolicy opts = maybe id corsPolicyFromString $ cors_ opts hledger-web-1.50.3/Hledger/Web/Application.hs0000644000000000000000000000445015106732206017046 0ustar0000000000000000{-| Complete the definition of the web app begun in App.hs. This is always done in two files for (TH?) reasons. -} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} module Hledger.Web.Application ( makeApplication , makeApp , makeAppWith ) where 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 Hledger.Data (Journal, nulljournal) import Hledger.Web.Handler.AddR import Hledger.Web.Handler.MiscR import Hledger.Web.Handler.EditR import Hledger.Web.Handler.UploadR import Hledger.Web.Handler.JournalR import Hledger.Web.Handler.RegisterR import Hledger.Web.Import import Hledger.Web.WebOptions (ServerMode(..), WebOpts(server_mode_), corsPolicy) -- mkYesodDispatch creates our YesodDispatch instance. -- It complements the mkYesodData call in App.hs, -- but must be in a separate file for (TH?) reasons. 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 app <- makeApp conf' opts' writeIORef (appJournal app) j' (logWare . (corsPolicy opts')) <$> toWaiApp app where logWare | development = logStdoutDev | server_mode_ opts' `elem` [Serve, ServeJson] = logStdout | otherwise = id makeApp :: AppConfig DefaultEnv Extra -> WebOpts -> IO App makeApp = makeAppWith nulljournal -- Make an "App" (defined in App.hs), -- with the given Journal as its state -- and the given "AppConfig" and "WebOpts" as its configuration. makeAppWith :: Journal -> AppConfig DefaultEnv Extra -> WebOpts -> IO App makeAppWith j' aconf wopts = do s <- staticSite m <- newManager defaultManagerSettings jref <- newIORef j' return App{ settings = aconf , getStatic = s , httpManager = m , appOpts = wopts , appJournal = jref } hledger-web-1.50.3/Hledger/Web/Import.hs0000644000000000000000000000227515054061121016051 0ustar0000000000000000module Hledger.Web.Import ( module Import ) where import Prelude as Import hiding (head, init, last, readFile, tail, writeFile) import Yesod as Import hiding (Route (..), parseTime) import Control.Monad as Import import Data.Bifunctor as Import import Data.ByteString as Import (ByteString) import Data.Default as Import import Data.Either as Import import Data.Foldable as Import import Data.List as Import (unfoldr) import Data.Maybe as Import import Data.Text as Import (Text) import Data.Time as Import import Data.Traversable as Import import Data.Void as Import (Void) import Text.Blaze as Import (Markup) import Hledger.Web.App as Import import Hledger.Web.Settings as Import import Hledger.Web.Settings.StaticFiles as Import import Hledger.Web.WebOptions as Import (Permission(..)) hledger-web-1.50.3/Hledger/Web/Test.hs0000644000000000000000000001445515107137141015526 0ustar0000000000000000{-| Test suite for hledger-web. Dev notes: http://hspec.github.io/writing-specs.html https://hackage.haskell.org/package/yesod-test-1.6.10/docs/Yesod-Test.html "The best way to see an example project using yesod-test is to create a scaffolded Yesod project: stack new projectname yesodweb/sqlite (See https://github.com/commercialhaskell/stack-templates/wiki#yesod for the full list of Yesod templates)" These tests don't exactly match the production code path, eg these bits are missing: withJournal copts (web wopts) -- extra withJournal logic (journalTransform..) ... -- query logic, more options logic let depthlessinitialq = filterQuery (not . queryIsDepth) . _rsQuery . reportspec_ $ cliopts_ wopts j' = filterJournalTransactions depthlessinitialq j h = host_ wopts p = port_ wopts u = base_url_ wopts staticRoot = T.pack <$> file_url_ wopts appconfig = AppConfig{appEnv = Development ,appHost = fromString h ,appPort = p ,appRoot = T.pack u ,appExtra = Extra "" Nothing staticRoot } The production code path, when called in this test context, which I guess is using yesod's dev mode, needs to read ./config/settings.yml and fails without it (loadConfig). -} {-# LANGUAGE OverloadedStrings #-} module Hledger.Web.Test ( hledgerWebTest ) where import Data.String (fromString) import Data.Function ((&)) import Data.Text qualified as T import Test.Hspec (hspec) import Yesod.Default.Config import Yesod.Test import Hledger.Web.Application ( makeAppWith ) import Hledger.Web.WebOptions -- ( WebOpts(..), defwebopts, prognameandversion ) import Hledger.Web.Import hiding (get, j) import Hledger.Cli hiding (prognameandversion) -- | Given a tests description, zero or more raw option name/value pairs, -- a journal and some hspec tests, parse the options and configure the -- web app more or less as we normally would (see details above), then run the tests. -- -- Raw option names are like the long flag without the --, eg "file" or "base-url". -- -- The journal and raw options should correspond enough to not cause problems. -- Be cautious - without a [("file", "somepath")], perhaps journalReload could load -- the user's default journal. -- runTests :: String -> [(String,String)] -> Journal -> YesodSpec App -> IO () runTests testsdesc rawopts j tests = do wopts <- rawOptsToWebOpts $ mkRawOpts rawopts let yconf = AppConfig{ -- :: AppConfig DefaultEnv Extra appEnv = Testing -- https://hackage.haskell.org/package/conduit-extra/docs/Data-Conduit-Network.html#t:HostPreference -- ,appHost = "*4" -- "any IPv4 or IPv6 hostname, IPv4 preferred" -- ,appPort = 3000 -- force a port for tests ? -- Test with the host and port from opts. XXX more fragile, can clash with a running instance ? ,appHost = host_ wopts & fromString ,appPort = port_ wopts ,appRoot = base_url_ wopts & T.pack -- XXX not sure this or extraStaticRoot get used ,appExtra = Extra { extraCopyright = "" , extraAnalytics = Nothing , extraStaticRoot = T.pack <$> file_url_ wopts } } app <- makeAppWith j yconf wopts hspec $ yesodSpec app $ ydescribe testsdesc tests -- https://hackage.haskell.org/package/yesod-test/docs/Yesod-Test.html -- | Run hledger-web's built-in tests using the hspec test runner. hledgerWebTest :: IO () hledgerWebTest = do putStrLn $ "Running tests for " ++ prognameandversion -- ++ " (--test --help for options)" let d = fromGregorian 2000 1 1 runTests "hledger-web" [] nulljournal $ do yit "serves a reasonable-looking journal page" $ do get JournalR statusIs 200 bodyContains "Add a transaction" yit "serves a reasonable-looking register page" $ do get RegisterR statusIs 200 bodyContains "accounts" yit "hyperlinks use a base url made from the default host and port" $ do get JournalR statusIs 200 let defaultbaseurl = defbaseurl defhost defport bodyContains ("href=\"" ++ defaultbaseurl) bodyContains ("src=\"" ++ defaultbaseurl) -- WIP -- yit "shows the add form" $ do -- get JournalR -- -- printBody -- -- let addbutton = "button:contains('add')" -- -- bodyContains addbutton -- -- htmlAnyContain "button:visible" "add" -- printMatches "div#addmodal:visible" -- htmlCount "div#addmodal:visible" 0 -- -- clickOn "a#addformlink" -- -- printBody -- -- bodyContains addbutton -- yit "can add transactions" $ do usecolor <- useColorOnStdout let rawopts = [("forecast","")] iopts = rawOptsToInputOpts d usecolor True $ mkRawOpts rawopts f = "fake" -- need a non-null filename so forecast transactions get index 0 pj <- readJournal'' (T.pack $ unlines -- PARTIAL: readJournal'' should not fail ["~ monthly" ," assets 10" ," income" ]) j <- fmap (either error' id) . runExceptT $ journalFinalise iopts f "" pj -- PARTIAL: journalFinalise should not fail runTests "hledger-web with --forecast" rawopts j $ do yit "shows forecasted transactions" $ do get JournalR statusIs 200 bodyContains "id=\"transaction-2-1\"" bodyContains "id=\"transaction-2-2\"" -- #2127 -- XXX I'm pretty sure this test lies, ie does not match production behaviour. -- (test with curl -s http://localhost:5000/journal | rg '(href)="[\w/].*?"' -o ) -- App root setup is a maze of twisty passages, all alike. -- runTests "hledger-web with --base-url" -- [("base-url","https://base")] nulljournal $ do -- yit "hyperlinks respect --base-url" $ do -- get JournalR -- statusIs 200 -- bodyContains "href=\"https://base" -- bodyContains "src=\"https://base" -- #2139 -- XXX Not passing. -- Static root setup is a maze of twisty passages, all different. -- runTests "hledger-web with --base-url, --file-url" -- [("base-url","https://base"), ("file-url","https://files")] nulljournal $ do -- yit "static file hyperlinks respect --file-url, others respect --base-url" $ do -- get JournalR -- statusIs 200 -- bodyContains "href=\"https://base" -- bodyContains "src=\"https://files" hledger-web-1.50.3/Hledger/Web/App.hs0000644000000000000000000003242215107137141015321 0ustar0000000000000000{-| Most of the definition of the web app is here. In the usual Yesod style, this defines the web app's core types and configuration, and then Application.hs completes the job. -} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Hledger.Web.App where import Control.Applicative ((<|>)) import Control.Monad (join, when, unless) -- import Control.Monad.Except (runExceptT) -- now re-exported by Hledger import Data.ByteString.Char8 qualified as BC import Data.Traversable (for) import Data.IORef (IORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Time.Calendar (Day) import Network.HTTP.Conduit (Manager) import Network.HTTP.Types (status403) import Network.Wai (requestHeaders) import System.Directory (XdgDirectory (..), createDirectoryIfMissing, getXdgDirectory) import System.FilePath (takeFileName, ()) import Text.Blaze (Markup) import Text.Hamlet (hamletFile) import Yesod import Yesod.Static import Yesod.Default.Config #ifndef DEVELOPMENT import Hledger.Web.Settings (staticDir) import Text.Jasmine (minifym) import Yesod.Default.Util (addStaticContentExternal) #endif import Hledger import Hledger.Cli (CliOpts(..), journalReloadIfChanged) import Hledger.Web.Settings (Extra(..), widgetFile) import Hledger.Web.Settings.StaticFiles import Hledger.Web.WebOptions import Hledger.Web.Widget.Common (balanceReportAsHtml) import Data.List (isPrefixOf) -- | 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 -- ^ the current journal, filtered by the initial command line query -- but ignoring any depth limit. } -- 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. -- AppCreating 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 the other in a -- separate file (Application.hs). -- mkYesodData defines things like: -- -- * type Handler = HandlerFor App -- HandlerT App IO, https://www.yesodweb.com/book/routing-and-handlers#routing-and-handlers_handler_monad -- * type Widget = WidgetFor App () -- WidgetT App IO (), https://www.yesodweb.com/book/widgets -- mkYesodData "App" $(parseRoutesFile "config/routes") type AppRoute = Route App type Form a = Html -> MForm Handler (FormResult a, Widget) -- 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 -- Configure the app root, AKA base url, which is prepended to relative hyperlinks. -- 1. when a --base-url was specified, use that -- 2. otherwise, guess it from request headers, which helps us respond from the same hostname/IP address when accessible via multiple IPs -- 3. otherwise, leave it empty (relative links stay relative). -- Past issues: #2099, #2100, #2127, #hledger-2024-07-18 approot | hasbaseurl = ApprootMaster (T.pack . base_url_ . appOpts) | otherwise = guessApprootOr (ApprootMaster (appRoot . settings)) where hasbaseurl = any ("--base-url" `isPrefixOf`) progArgs -- needs unsafePerformIO; does not detect abbreviations like --base makeSessionBackend _ = do hledgerdata <- getXdgDirectory XdgCache "hledger" createDirectoryIfMissing True hledgerdata let sessionexpirysecs = 120 Just <$> defaultClientSessionBackend sessionexpirysecs (hledgerdata "hledger-web_client_session_key.aes") -- defaultLayout :: WidgetFor site () -> HandlerFor site Html defaultLayout widget = do -- Don't run if server-side UI is disabled. -- This single check probably covers all the HTML-returning handlers, -- but for now they do the check as well. checkServerSideUiEnabled master <- getYesod here <- fromMaybe RootR <$> getCurrentRoute VD{opts, j, qparam, q, qopts, perms} <- getViewData msg <- getMessage showSidebar <- shouldShowSidebar let rspec = reportspec_ (cliopts_ opts) ropts = _rsReportOpts rspec ropts' = (_rsReportOpts rspec) {accountlistmode_ = ALTree -- force tree mode for sidebar ,empty_ = True -- show zero items by default } rspec' = rspec{_rsQuery=q,_rsReportOpts=ropts'} hideEmptyAccts <- if empty_ ropts then return True else (== Just "1") . lookup "hideemptyaccts" . reqCookies <$> getRequest let accounts = balanceReportAsHtml (JournalR, RegisterR) here hideEmptyAccts j qparam qopts $ styleAmounts (journalCommodityStylesWith HardRounding j) $ balanceReport rspec' j topShowmd = if showSidebar then "col-md-4" else "col-any-0" :: Text topShowsm = if showSidebar then "col-sm-4" else "" :: Text sideShowmd = if showSidebar then "col-md-4" else "col-any-0" :: Text sideShowsm = if showSidebar then "col-sm-4" else "" :: Text mainShowmd = if showSidebar then "col-md-8" else "col-md-12" :: Text mainShowsm = if showSidebar then "col-sm-8" else "col-sm-12" :: Text -- 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 addStylesheet $ StaticR css_bootstrap_min_css addStylesheet $ StaticR css_bootstrap_datepicker_standalone_min_css -- load these things early, in HEAD: toWidgetHead [hamlet|