slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

web: switch to new matchers, account links now show related postings, more ui cleanups

Browse Source
This commit is contained in:
Simon Michael 2011-06-05 18:43:06 +00:00
parent 635b6c60e7
commit e8660d98d8
9 changed files with 71 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
hledger-web/.hledger/web/static/style.css
View File

@ -39,7 +39,7 @@ input.textinput, .dhx_combo_input, .dhx_combo_list { font-size:small; }
.journalreport { font-size:small; } .journalreport { font-size:small; }
.balancereport { font-size:small; } .balancereport { font-size:small; }
.registerreport { font-size:small; } .registerreport { font-size:small; }
#showmoreaccounts { font-size:small; } .showall { font-size:small; }
/* #addformlink { font-size:small; } */ /* #addformlink { font-size:small; } */
/* #editformlink { font-size:small; } */ /* #editformlink { font-size:small; } */
@ -77,7 +77,7 @@ body { margin:0; }
#main .journal { } #main .journal { }
#main .register { } #main .register { }
/* .current { font-weight:bold; } */ .current { font-weight:bold; }
.description { padding-left:1em; white-space:normal; } .description { padding-left:1em; white-space:normal; }
.account { white-space:normal; padding-left:1em; } .account { white-space:normal; padding-left:1em; }
.amount { white-space:nowrap; padding-left:1em; } .amount { white-space:nowrap; padding-left:1em; }
@ -102,7 +102,6 @@ table.registerreport { border-spacing:0; }
.registerreport .date { white-space:nowrap; } .registerreport .date { white-space:nowrap; }
.firstposting td { } .firstposting td { }
#accountsheading { white-space:nowrap; margin-bottom:1em; } #accountsheading { white-space:nowrap; margin-bottom:1em; }
#showmoreaccounts { font-weight:bold; }
#addform input.textinput, #addform .dhx_combo_input, .dhx_combo_list { padding:4px; } #addform input.textinput, #addform .dhx_combo_input, .dhx_combo_list { padding:4px; }

6
hledger-web/.hledger/web/templates/accountsheading.hamlet
View File

@ -1,4 +1,6 @@
<div#accountsheading <div#accountsheading
accounts accounts
\ # $if filtering
^{showlinks} \ #
<span.showall
<a href=@{here}>show all

1
hledger-web/.hledger/web/templates/accountsheadinglinks.hamlet
View File

@ -1 +0,0 @@
<span#showmoreaccounts>^{showmore} ^{showall}

2
hledger-web/.hledger/web/templates/accountsheadinglinksall.hamlet
View File

@ -1,2 +0,0 @@
\ | #
<a href=@?{allurl}>show all

2
hledger-web/.hledger/web/templates/accountsheadinglinksmore.hamlet
View File

@ -1,2 +0,0 @@
\ | #
<a href=@?{parenturl}>show more &uarr;

2
hledger-web/.hledger/web/templates/balancereportitem.hamlet
View File

@ -1,5 +1,5 @@
<tr.item <tr.item
<td.account <td.account
#{indent} #{indent}
<a href="@{here}?a=#{acctpat}#{pparam}">#{adisplay} <a href="@?{accturl}">#{adisplay}
<td.balance align=right>#{mixedAmountAsHtml abal} <td.balance align=right>#{mixedAmountAsHtml abal}

7
hledger-web/.hledger/web/templates/filterform.hamlet
View File

@ -7,6 +7,7 @@
\ # \ #
<td <td
<input name=q size=100 value=#{q} <input name=q size=100 value=#{q}
\# $if filtering
<td align=right \ #
^{stopfiltering} <span.showall
<a href=@{here}>show all

159
hledger-web/Handlers.hs
View File

@ -18,7 +18,6 @@ import Data.Time.Calendar
import System.FilePath (takeFileName, (</>)) import System.FilePath (takeFileName, (</>))
import System.IO.Storage (putValue, getValue) import System.IO.Storage (putValue, getValue)
import Text.Hamlet hiding (hamletFile) import Text.Hamlet hiding (hamletFile)
import Text.ParserCombinators.Parsec -- hiding (string)
import Text.Printf import Text.Printf
import Text.RegexPR import Text.RegexPR
import Yesod.Form import Yesod.Form
@ -56,9 +55,9 @@ getRootR = redirect RedirectTemporary defaultroute where defaultroute = Register
-- | The main journal view, with accounts sidebar. -- | The main journal view, with accounts sidebar.
getJournalR :: Handler RepHtml getJournalR :: Handler RepHtml
getJournalR = do getJournalR = do
vd@VD{opts=opts,fspec=fspec,j=j} <- getViewData vd@VD{opts=opts,m=m,j=j} <- getViewData
let sidecontent = balanceReportAsHtml opts vd $ balanceReport opts fspec j let sidecontent = balanceReportAsHtml opts vd{q=""} $ balanceReport opts nullfilterspec j
maincontent = journalReportAsHtml opts vd $ journalReport opts fspec j maincontent = journalReportAsHtml opts vd $ journalReport opts nullfilterspec $ filterJournalTransactions2 m j
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal" setTitle "hledger-web journal"
addHamlet $(Settings.hamletFile "journal") addHamlet $(Settings.hamletFile "journal")
@ -69,9 +68,9 @@ postJournalR = handlePost
-- | The main register view, with accounts sidebar. -- | The main register view, with accounts sidebar.
getRegisterR :: Handler RepHtml getRegisterR :: Handler RepHtml
getRegisterR = do getRegisterR = do
vd@VD{opts=opts,fspec=fspec,m=m,j=j} <- getViewData vd@VD{opts=opts,m=m,j=j} <- getViewData
let sidecontent = balanceReportAsHtml opts vd $ balanceReport opts fspec $ filterJournalPostings2 m j let sidecontent = balanceReportAsHtml opts vd{q=""} $ balanceReport opts nullfilterspec j
maincontent = registerReportAsHtml opts vd $ registerReport opts fspec $ filterJournalPostings2 m j maincontent = registerReportAsHtml opts vd $ registerReport opts nullfilterspec $ filterJournalPostings2 m j
editform' = editform vd editform' = editform vd
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web register" setTitle "hledger-web register"
@ -83,10 +82,10 @@ postRegisterR = handlePost
-- | A simple journal view, like hledger print (with editing.) -- | A simple journal view, like hledger print (with editing.)
getJournalOnlyR :: Handler RepHtml getJournalOnlyR :: Handler RepHtml
getJournalOnlyR = do getJournalOnlyR = do
vd@VD{opts=opts,fspec=fspec,j=j} <- getViewData vd@VD{opts=opts,m=m,j=j} <- getViewData
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal only" setTitle "hledger-web journal only"
addHamlet $ journalReportAsHtml opts vd $ journalReport opts fspec j addHamlet $ journalReportAsHtml opts vd $ journalReport opts nullfilterspec $ filterJournalTransactions2 m j
postJournalOnlyR :: Handler RepPlain postJournalOnlyR :: Handler RepPlain
postJournalOnlyR = handlePost postJournalOnlyR = handlePost
@ -94,63 +93,60 @@ postJournalOnlyR = handlePost
-- | A simple postings view, like hledger register (with editing.) -- | A simple postings view, like hledger register (with editing.)
getRegisterOnlyR :: Handler RepHtml getRegisterOnlyR :: Handler RepHtml
getRegisterOnlyR = do getRegisterOnlyR = do
vd@VD{opts=opts,fspec=fspec,j=j} <- getViewData vd@VD{opts=opts,m=m,j=j} <- getViewData
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web register only" setTitle "hledger-web register only"
addHamlet $ registerReportAsHtml opts vd $ registerReport opts fspec j addHamlet $ registerReportAsHtml opts vd $ registerReport opts nullfilterspec $ filterJournalPostings2 m j
postRegisterOnlyR :: Handler RepPlain postRegisterOnlyR :: Handler RepPlain
postRegisterOnlyR = handlePost postRegisterOnlyR = handlePost
-- | A simple accounts view, like hledger balance. If the Accept header -- | A simple accounts view, like hledger balance. If the Accept header
-- specifies json, returns the chart of accounts as json. -- specifies json, returns the chart of accounts as json.
getAccountsOnlyR :: Handler RepHtmlJson getAccountsR :: Handler RepHtmlJson
getAccountsOnlyR = do getAccountsR = do
vd@VD{opts=opts,fspec=fspec,j=j,a=a} <- getViewData vd@VD{opts=opts,m=m,j=j} <- getViewData
let accountNames = journalAccountNames j :: [AccountName] let j' = filterJournalPostings2 m j
accountNames' = filter (matchpats [a]) $ accountNames
json = jsonMap [("accounts", toJSON $ accountNames')]
html = do html = do
setTitle "hledger-web accounts" setTitle "hledger-web accounts"
addHamlet $ balanceReportAsHtml opts vd $ balanceReport opts fspec j addHamlet $ balanceReportAsHtml opts vd $ balanceReport opts nullfilterspec j'
json = jsonMap [("accounts", toJSON $ journalAccountNames j')]
defaultLayoutJson html json defaultLayoutJson html json
-- | Return the chart of accounts as json, without needing a special Accept header. -- | Return the chart of accounts as json, without needing a special Accept header.
getAccountsJsonR :: Handler RepJson getAccountsJsonR :: Handler RepJson
getAccountsJsonR = do getAccountsJsonR = do
VD{a=a,j=j} <- getViewData VD{m=m,j=j} <- getViewData
let accountNames = journalAccountNames j :: [AccountName] let j' = filterJournalPostings2 m j
accountNames' = filter (matchpats [a]) $ accountNames jsonToRepJson $ jsonMap [("accounts", toJSON $ journalAccountNames j')]
jsonToRepJson $ jsonMap [("accounts", toJSON $ accountNames')]
-- helpers -- helpers
-- | Render a balance report as HTML. -- | Render a balance report as HTML.
balanceReportAsHtml :: [Opt] -> ViewData -> BalanceReport -> Hamlet AppRoute balanceReportAsHtml :: [Opt] -> ViewData -> BalanceReport -> Hamlet AppRoute
balanceReportAsHtml _ vd@VD{here=here,a=a,p=p} (items,total) = $(Settings.hamletFile "balancereport") balanceReportAsHtml _ vd@VD{here=here,q=q} (items,total) = $(Settings.hamletFile "balancereport")
where where
itemAsHtml :: ViewData -> BalanceReportItem -> Hamlet AppRoute itemAsHtml :: ViewData -> BalanceReportItem -> Hamlet AppRoute
itemAsHtml VD{p=p} (acct, adisplay, adepth, abal) = $(Settings.hamletFile "balancereportitem") itemAsHtml VD{here=here,q=q} (acct, adisplay, adepth, abal) = $(Settings.hamletFile "balancereportitem")
where where
indent = preEscapedString $ concat $ replicate (2 * adepth) "&nbsp;" indent = preEscapedString $ concat $ replicate (2 * adepth) "&nbsp;"
acctpat = accountNameToAccountRegex acct accturl = (here, [("q", pack $ "otheracct:" ++ quoteIfSpaced (accountNameToAccountRegex acct))])
pparam = if null p then "" else "&p="++p
accountsheading = $(Settings.hamletFile "accountsheading") accountsheading = $(Settings.hamletFile "accountsheading")
where where
filteringaccts = not $ null a filtering = not $ null q
showlinks = $(Settings.hamletFile "accountsheadinglinks") -- showlinks = $(Settings.hamletFile "accountsheadinglinks")
showmore = case (filteringaccts, items) of -- showmore = case (filteringaccts, items) of
-- cunning parent account logic -- -- cunning parent account logic
(True, ((acct, _, _, _):_)) -> -- (True, ((acct, _, _, _):_)) ->
let a' = if isAccountRegex a then a else acct -- let a' = if isAccountRegex a then a else acct
a'' = accountNameToAccountRegex $ parentAccountName $ accountRegexToAccountName a' -- a'' = accountNameToAccountRegex $ parentAccountName $ accountRegexToAccountName a'
parenturl = (here, [("a",pack a''), ("p",pack p)]) -- parenturl = (here, [("a",pack a''), ("p",pack p)])
in $(Settings.hamletFile "accountsheadinglinksmore") -- in $(Settings.hamletFile "accountsheadinglinksmore")
_ -> nulltemplate -- _ -> nulltemplate
showall = if filteringaccts -- showall = if filteringaccts
then $(Settings.hamletFile "accountsheadinglinksall") -- then $(Settings.hamletFile "accountsheadinglinksall")
else nulltemplate -- else nulltemplate
where allurl = (here, [("p",pack p)]) -- where allurl = (here, [])
-- | Render a journal report as HTML. -- | Render a journal report as HTML.
journalReportAsHtml :: [Opt] -> ViewData -> JournalReport -> Hamlet AppRoute journalReportAsHtml :: [Opt] -> ViewData -> JournalReport -> Hamlet AppRoute
@ -167,14 +163,13 @@ registerReportAsHtml :: [Opt] -> ViewData -> RegisterReport -> Hamlet AppRoute
registerReportAsHtml _ vd items = $(Settings.hamletFile "registerreport") registerReportAsHtml _ vd items = $(Settings.hamletFile "registerreport")
where where
itemAsHtml :: ViewData -> (Int, RegisterReportItem) -> Hamlet AppRoute itemAsHtml :: ViewData -> (Int, RegisterReportItem) -> Hamlet AppRoute
itemAsHtml VD{here=here,p=p} (n, (ds, posting, b)) = $(Settings.hamletFile "registerreportitem") itemAsHtml VD{here=here} (n, (ds, posting, b)) = $(Settings.hamletFile "registerreportitem")
where where
evenodd = if even n then "even" else "odd" :: String evenodd = if even n then "even" else "odd" :: String
(firstposting, date, desc) = case ds of Just (da, de) -> ("firstposting", show da, de) (firstposting, date, desc) = case ds of Just (da, de) -> ("firstposting", show da, de)
Nothing -> ("", "", "") :: (String,String,String) Nothing -> ("", "", "") :: (String,String,String)
acct = paccount posting acct = paccount posting
acctpat = accountNameToAccountRegex acct accturl = (here, [("q", pack $ "otheracct:" ++ quoteIfSpaced (accountNameToAccountRegex acct))])
pparam = if null p then "" else "&p="++p
mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ show b mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ show b
where addclass = printf "<span class=\"%s\">%s</span>" (c :: String) where addclass = printf "<span class=\"%s\">%s</span>" (c :: String)
@ -318,20 +313,9 @@ handleImport = do
-- | Global toolbar/heading area. -- | Global toolbar/heading area.
topbar :: ViewData -> Hamlet AppRoute topbar :: ViewData -> Hamlet AppRoute
topbar VD{p=p,j=j,msg=msg,today=today} = $(Settings.hamletFile "topbar") topbar VD{j=j,msg=msg,today=today} = $(Settings.hamletFile "topbar")
where where
(title, desc) = journalTitleDesc j p today title = takeFileName $ journalFilePath j
-- | Generate a title and description for the given journal, period
-- expression, and date.
journalTitleDesc :: Journal -> String -> Day -> (String, String)
journalTitleDesc j p today = (title, desc)
where
title = printf "%s" (takeFileName $ journalFilePath j) :: String
desc = printf "%s" (showspan span) :: String
span = either (const $ DateSpan Nothing Nothing) snd (parsePeriodExpr today p)
showspan (DateSpan Nothing Nothing) = ""
showspan s = " (" ++ dateSpanAsText s ++ ")"
-- | Links to navigate between the main views. -- | Links to navigate between the main views.
navlinks :: ViewData -> Hamlet AppRoute navlinks :: ViewData -> Hamlet AppRoute
@ -340,9 +324,8 @@ navlinks vd = $(Settings.hamletFile "navlinks")
accountsjournallink = navlink vd "transactions" JournalR accountsjournallink = navlink vd "transactions" JournalR
accountsregisterlink = navlink vd "postings" RegisterR accountsregisterlink = navlink vd "postings" RegisterR
navlink :: ViewData -> String -> AppRoute -> Hamlet AppRoute navlink :: ViewData -> String -> AppRoute -> Hamlet AppRoute
navlink VD{here=here,a=a,p=p} s dest = $(Settings.hamletFile "navlink") navlink VD{here=here,q=q} s dest = $(Settings.hamletFile "navlink")
where u = (dest, concat [(if null a then [] else [("a", pack a)]) where u = (dest, if null q then [] else [("q", pack q)])
,(if null p then [] else [("p", pack p)])])
style | dest == here = "navlinkcurrent" style | dest == here = "navlinkcurrent"
| otherwise = "navlink" :: Text | otherwise = "navlink" :: Text
@ -357,10 +340,10 @@ helplink topic label = $(Settings.hamletFile "helplink")
-- | Form controlling journal filtering parameters. -- | Form controlling journal filtering parameters.
filterform :: ViewData -> Hamlet AppRoute filterform :: ViewData -> Hamlet AppRoute
filterform VD{here=here,a=a,p=p,q=q} = $(Settings.hamletFile "filterform") filterform VD{here=here,q=q} = $(Settings.hamletFile "filterform")
where where
ahelp = helplink "filter-patterns" "?" -- ahelp = helplink "filter-patterns" "?"
phelp = helplink "period-expressions" "?" -- phelp = helplink "period-expressions" "?"
filtering = not $ null q filtering = not $ null q
visible = "block" :: String visible = "block" :: String
filteringclass = if filtering then "filtering" else "" :: String filteringclass = if filtering then "filtering" else "" :: String
@ -413,17 +396,14 @@ journalselect journalfiles = $(Settings.hamletFile "journalselect")
-- utilities -- utilities
nulltemplate :: Hamlet AppRoute nulltemplate :: Hamlet AppRoute
nulltemplate = [$hamlet||] nulltemplate = [hamlet||]
-- | A bundle of data useful for handlers and their templates. -- | A bundle of data useful for handlers and their templates.
data ViewData = VD { data ViewData = VD {
opts :: [Opt] -- ^ command-line options at startup opts :: [Opt] -- ^ command-line options at startup
,a :: String -- ^ current a (query) parameter
,p :: String -- ^ current p (query) parameter
,q :: String -- ^ current q (query) parameter ,q :: String -- ^ current q (query) parameter
,fspec :: FilterSpec -- ^ a journal filter specification based on the above
,m :: Matcher -- ^ a search/filter expression based on the above ,m :: Matcher -- ^ a search/filter expression based on the above
,j :: Journal -- ^ an up-to-date parsed journal ,j :: Journal -- ^ the up-to-date parsed unfiltered journal
,today :: Day -- ^ the current day ,today :: Day -- ^ the current day
,here :: AppRoute -- ^ the current route ,here :: AppRoute -- ^ the current route
,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request ,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request
@ -432,10 +412,7 @@ data ViewData = VD {
mkvd :: ViewData mkvd :: ViewData
mkvd = VD { mkvd = VD {
opts = [] opts = []
,a = ""
,p = ""
,q = "" ,q = ""
,fspec = nullfilterspec
,m = MatchOr [] ,m = MatchOr []
,j = nulljournal ,j = nulljournal
,today = ModifiedJulianDay 0 ,today = ModifiedJulianDay 0
@ -446,25 +423,16 @@ mkvd = VD {
-- | Gather data useful for a hledger-web request handler and its templates. -- | Gather data useful for a hledger-web request handler and its templates.
getViewData :: Handler ViewData getViewData :: Handler ViewData
getViewData = do getViewData = do
Just here' <- getCurrentRoute app <- getYesod
(q, opts, fspec, m) <- getCurrentParameters let opts = appOpts app
(j, err) <- getCurrentJournal opts (j, err) <- getCurrentJournal opts
msg <- getMessageOr err msg <- getMessageOr err
today <- liftIO getCurrentDay Just here' <- getCurrentRoute
return mkvd{opts=opts, q=q, fspec=fspec, m=m, j=j, today=today, here=here', msg=msg} today <- liftIO getCurrentDay
q <- getParameter "q"
let m = parseMatcher today q
return mkvd{opts=opts, q=q, m=m, j=j, today=today, here=here', msg=msg}
where where
-- | Get current report parameters for this request.
getCurrentParameters :: Handler (String, [Opt], FilterSpec, Matcher)
getCurrentParameters = do
app <- getYesod
t <- liftIO $ getCurrentLocalTime
q <- unpack `fmap` fromMaybe "" <$> lookupGetParam "q"
let opts = appOpts app -- ++ [Period p']
args = appArgs app -- ++ words' a'
fspec = optsToFilterSpec opts args t
m = parseMatcher q
return (q, opts, fspec, m)
-- | Update our copy of the journal if the file changed. If there is an -- | Update our copy of the journal if the file changed. If there is an
-- error while reloading, keep the old one and return the error, and set a -- error while reloading, keep the old one and return the error, and set a
-- ui message. -- ui message.
@ -480,18 +448,9 @@ getViewData = do
Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-} Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-}
return (j, Just e) return (j, Just e)
-- | Get the named request parameter.
parseMatcher :: String -> Matcher getParameter :: String -> Handler String
parseMatcher s = MatchOr $ map (MatchAcct True) $ words' s getParameter p = unpack `fmap` fromMaybe "" <$> lookupGetParam (pack p)
parseMatcher2 :: String -> Matcher
parseMatcher2 s = either (const (MatchOr [])) id $ runParser matcher () "" $ lexmatcher s
lexmatcher :: String -> [String]
lexmatcher s = words' s
matcher :: GenParser String () Matcher
matcher = undefined
-- | Get the message set by the last request, or the newer message provided, if any. -- | Get the message set by the last request, or the newer message provided, if any.
getMessageOr :: Maybe String -> Handler (Maybe Html) getMessageOr :: Maybe String -> Handler (Maybe Html)

2
hledger-web/routes
View File

@ -6,5 +6,5 @@
/register RegisterR GET POST /register RegisterR GET POST
/journalonly JournalOnlyR GET POST /journalonly JournalOnlyR GET POST
/registeronly RegisterOnlyR GET POST /registeronly RegisterOnlyR GET POST
/accountsonly AccountsOnlyR GET /accounts AccountsR GET
/accountsjson AccountsJsonR GET /accountsjson AccountsJsonR GET