hledger-web-1.32.3/Hledger/0000755000000000000000000000000014555053231013530 5ustar0000000000000000hledger-web-1.32.3/Hledger/Web/0000755000000000000000000000000014555053231014245 5ustar0000000000000000hledger-web-1.32.3/Hledger/Web/Handler/0000755000000000000000000000000014555423340015624 5ustar0000000000000000hledger-web-1.32.3/Hledger/Web/Settings/0000755000000000000000000000000014555053231016045 5ustar0000000000000000hledger-web-1.32.3/Hledger/Web/Widget/0000755000000000000000000000000014555423340015472 5ustar0000000000000000hledger-web-1.32.3/app/0000755000000000000000000000000014513751565012747 5ustar0000000000000000hledger-web-1.32.3/config/0000755000000000000000000000000014434445206013426 5ustar0000000000000000hledger-web-1.32.3/static/0000755000000000000000000000000014513751565013456 5ustar0000000000000000hledger-web-1.32.3/static/css/0000755000000000000000000000000014112603266014233 5ustar0000000000000000hledger-web-1.32.3/static/fonts/0000755000000000000000000000000014112603266014574 5ustar0000000000000000hledger-web-1.32.3/static/js/0000755000000000000000000000000014434445206014064 5ustar0000000000000000hledger-web-1.32.3/templates/0000755000000000000000000000000014555053231014154 5ustar0000000000000000hledger-web-1.32.3/test/0000755000000000000000000000000014513751565013146 5ustar0000000000000000hledger-web-1.32.3/Hledger/Web.hs0000644000000000000000000000106414555053231014602 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.32.3/Hledger/Web/Main.hs0000644000000000000000000001225714555053231015474 0ustar0000000000000000{-| hledger-web - a basic but robust web UI and JSON API server for hledger. Copyright (c) 2007-2023 Simon Michael and contributors. Released under GPL version 3 or later. -} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Hledger.Web.Main where import Control.Exception (bracket) import Control.Monad (when) import Data.String (fromString) import qualified Data.Text 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.Exit (exitSuccess, exitFailure) 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 = withJournalDo (cliopts_ defwebopts) (defaultDevelApp loader . makeApplication defwebopts) where loader = Yesod.Default.Config.loadConfig (configSettings Development) {csParseExtra = parseExtra} -- Run normally. hledgerWebMain :: IO () hledgerWebMain = do -- try to encourage user's $PAGER to properly display ANSI (in command line help) when useColorOnStdout 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_ -> pager (showModeUsage webmode) >> exitSuccess | boolopt "info" rawopts_ -> runInfoForTopic "hledger-web" Nothing | boolopt "man" rawopts_ -> runManForTopic "hledger-web" Nothing | boolopt "version" rawopts_ -> putStrLn prognameandversion >> exitSuccess -- 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 -> withJournalDo copts (web wopts) -- | 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 | serve_api_ opts = "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 serve_ opts || serve_api_ opts then 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 do putStrLn "Unix domain sockets are not available on your operating system" putStrLn "Please try again without --socket" exitFailure Nothing -> Network.Wai.Handler.Warp.runSettings warpsettings app else 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 hledger-web-1.32.3/Hledger/Web/WebOptions.hs0000644000000000000000000001770114555053231016700 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Hledger.Web.WebOptions where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC import Data.ByteString.UTF8 (fromString) import Data.Default (Default(def)) import Data.Maybe (fromMaybe) import Data.Text (Text) 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 qualified Data.Text as T import Data.Char (toLower) -- cf Hledger.Cli.Version packageversion :: PackageVersion packageversion = #ifdef VERSION VERSION #else "" #endif progname :: ProgramName progname = "hledger-web" prognameandversion :: VersionString prognameandversion = versionString progname packageversion webflags :: [Flag RawOpts] webflags = [ flagNone ["serve", "server"] (setboolopt "serve") "serve and log requests, don't browse or auto-exit" , flagNone ["serve-api"] (setboolopt "serve-api") "like --serve, but serve only the JSON web API, not the web UI" , 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 (unix only; implies --serve)" , 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" ] 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 -- ["binary-filename"] -- (setboolopt "binary-filename") -- "show the download filename for this executable, and exit" -- ] , groupNamed = [generalflagsgroup1] } , modeHelpSuffix = [] } -- hledger-web options, used in hledger-web and above data WebOpts = WebOpts { serve_ :: !Bool , serve_api_ :: !Bool , 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 { serve_ = False , serve_api_ = False , 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 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 { serve_ = case sock of Just _ -> True Nothing -> boolopt "serve" rawopts , serve_api_ = boolopt "serve-api" 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 checkWebOpts :: WebOpts -> WebOpts checkWebOpts = id getHledgerWebOpts :: IO WebOpts getHledgerWebOpts = do args <- fmap (replaceNumericFlags . ensureDebugHasArg) . 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.32.3/Hledger/Web/Application.hs0000644000000000000000000000442114555053231017045 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 (WebOpts(serve_,serve_api_), 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 | serve_ opts' || serve_api_ opts' = 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.32.3/Hledger/Web/Import.hs0000644000000000000000000000227514555053231016061 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.32.3/Hledger/Web/Test.hs0000644000000000000000000001440114555053231015520 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: withJournalDo copts (web wopts) -- extra withJournalDo 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 qualified Data.Text 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 let rawopts = [("forecast","")] iopts = rawOptsToInputOpts d $ 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.32.3/Hledger/Web/App.hs0000644000000000000000000003254414555053231015331 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 qualified Data.ByteString.Char8 as BC import Data.Traversable (for) import Data.IORef (IORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text 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) -- | 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. -- Broadly, we'd like this: -- 1. when --base-url has been specified, use that; -- 2. otherwise, guess it from request headers, which helps us respond from the -- same hostname/IP address when hledger-web is accessible at multiple IPs; -- 3. otherwise, leave it empty (relative links stay relative). -- But it's hard to see how to achieve this. -- For now we do (I believe) 1 or 3, with 2 unfortunately not supported. -- Issues include: #2099, #2100, #2127 approot = -- ApprootRelative -- ApprootMaster $ appRoot . settings -- guessApprootOr (ApprootMaster $ appRoot . settings) ApprootMaster $ \(App{settings=AppConfig{appRoot=r}, appOpts=WebOpts{base_url_=bu}}) -> if null bu then r else T.pack bu 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|