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

web: upgrade to yesod 0.8

Browse Source
This commit is contained in:
Simon Michael 2011-05-21 02:52:42 +00:00
parent 883bc240c9
commit 024cfdb7b1
4 changed files with 337 additions and 310 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

617
hledger-web/Hledger/Web/App.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, GeneralizedNewtypeDeriving, OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
{-| {-|
The web app providing a richer interface to hledger's data. The web app providing a richer interface to hledger's data.
@ -11,11 +11,14 @@ module Hledger.Web.App
where where
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
-- import Control.Failure -- import Control.Failure
-- import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Either import Data.Either
-- import System.Directory -- import qualified Data.Text as T
import Data.Text(Text,pack,unpack)
import System.Directory
import System.FilePath ((</>), takeFileName) import System.FilePath ((</>), takeFileName)
import System.IO.Storage (putValue, getValue) import System.IO.Storage (putValue, getValue)
import Text.Jasmine (minifym)
import Text.ParserCombinators.Parsec hiding (string) import Text.ParserCombinators.Parsec hiding (string)
-- import Database.Persist.GenericSql (ConnectionPool, SqlPersist, runMigration, migrate) -- import Database.Persist.GenericSql (ConnectionPool, SqlPersist, runMigration, migrate)
@ -37,24 +40,24 @@ import Hledger.Cli.Version (version)
import Hledger.Data hiding (insert, today) import Hledger.Data hiding (insert, today)
import Hledger.Read (journalFromPathAndString) import Hledger.Read (journalFromPathAndString)
import Hledger.Read.JournalReader (someamount) import Hledger.Read.JournalReader (someamount)
import Hledger.Web.Settings ( import Hledger.Web.Settings
-- withConnectionPool -- -- withConnectionPool
-- , runConnectionPool -- -- , runConnectionPool
-- , staticroot -- -- , staticroot
datadir -- datadir
-- , hamletFile -- -- , hamletFile
-- , cassiusFile -- -- , cassiusFile
-- , juliusFile -- -- , juliusFile
, hledgerorgurl -- -- , hledgerorgurl
, manualurl -- , manualurl
, style_css -- -- , style_css
, hledger_js -- -- , hledger_js
, jquery_js -- -- , jquery_js
, jquery_url_js -- -- , jquery_url_js
, dhtmlxcommon_js -- -- , dhtmlxcommon_js
, dhtmlxcombo_js -- -- , dhtmlxcombo_js
, robots_txt -- , robots_txt
) -- )
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -80,12 +83,12 @@ import Hledger.Web.Settings (
-- run-time data kept by the web app. -- run-time data kept by the web app.
data App = App data App = App
{ -- appConnPool :: Maybe ConnectionPool { -- appConnPool :: Maybe ConnectionPool
appRoot :: String appRoot :: Text
,appDataDir :: FilePath ,appDataDir :: FilePath
,appOpts :: [Opt] ,appOpts :: [Opt]
,appArgs :: [String] ,appArgs :: [String]
,appStaticSettings :: Static
,appJournal :: Journal ,appJournal :: Journal
,appStatic :: Static
} }
-- parseRoutes (quasi-quoter from web-routes) defines a list of route patterns for the web app. -- parseRoutes (quasi-quoter from web-routes) defines a list of route patterns for the web app.
@ -93,9 +96,9 @@ data App = App
-- /auth AuthR Auth getAuth -- /auth AuthR Auth getAuth
mkYesod "App" [$parseRoutes| mkYesod "App" [$parseRoutes|
/ IndexR GET / IndexR GET
/static StaticR Static appStaticSettings
/favicon.ico FaviconR GET /favicon.ico FaviconR GET
/robots.txt RobotsR GET /robots.txt RobotsR GET
/static StaticR Static appStatic
/journalonly JournalOnlyR GET POST /journalonly JournalOnlyR GET POST
/registeronly RegisterOnlyR GET /registeronly RegisterOnlyR GET
/accounts AccountsOnlyR GET /accounts AccountsOnlyR GET
@ -108,6 +111,24 @@ type Handler = GHandler App App
instance Yesod App where instance Yesod App where
approot = appRoot approot = appRoot
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
addStaticContent ext' _ content = do
let fn = base64md5 content ++ '.' : unpack ext'
let content' =
if ext' == "js"
then case minifym content of
Left _ -> content
Right y -> y
else content
let statictmp = Hledger.Web.Settings.datadir ++ "/tmp/"
liftIO $ createDirectoryIfMissing True statictmp
let fn' = statictmp ++ fn
exists <- liftIO $ doesFileExist fn'
unless exists $ liftIO $ L.writeFile fn' content'
return $ Just $ Right (StaticR $ StaticRoute ["tmp", pack fn] [], [])
-- defaultLayout widget = do -- defaultLayout widget = do
-- mmsg <- getMessage -- mmsg <- getMessage
@ -230,6 +251,7 @@ withApp app f = toWaiApp app >>= f
-- handler utilities, common templates -- handler utilities, common templates
---------------------------------------------------------------------- ----------------------------------------------------------------------
nulltemplate :: Hamlet AppRoute
nulltemplate = [$hamlet||] nulltemplate = [$hamlet||]
-- | A bundle of useful data passed to templates. -- | A bundle of useful data passed to templates.
@ -243,6 +265,7 @@ data TemplateData = TD {
,today :: Day -- ^ the current day ,today :: Day -- ^ the current day
} }
mktd :: TemplateData
mktd = TD { mktd = TD {
here = IndexR here = IndexR
,title = "hledger" ,title = "hledger"
@ -260,11 +283,11 @@ mktd = TD {
-- message if any. -- message if any.
getHandlerData :: Handler (String, String, [Opt], FilterSpec, Journal, Maybe Html, AppRoute) getHandlerData :: Handler (String, String, [Opt], FilterSpec, Journal, Maybe Html, AppRoute)
getHandlerData = do getHandlerData = do
Just here <- getCurrentRoute Just here' <- getCurrentRoute
(a, p, opts, fspec) <- getReportParameters (a, p, opts, fspec) <- getReportParameters
(j, err) <- getLatestJournal opts (j, err) <- getLatestJournal opts
msg <- getMessage' err msg <- getMessage' err
return (a, p, opts, fspec, j, msg, here) return (a, p, opts, fspec, j, msg, here')
where where
-- | Get current report parameters for this request. -- | Get current report parameters for this request.
getReportParameters :: Handler (String, String, [Opt], FilterSpec) getReportParameters :: Handler (String, String, [Opt], FilterSpec)
@ -273,10 +296,11 @@ getHandlerData = do
t <- liftIO $ getCurrentLocalTime t <- liftIO $ getCurrentLocalTime
a <- fromMaybe "" <$> lookupGetParam "a" a <- fromMaybe "" <$> lookupGetParam "a"
p <- fromMaybe "" <$> lookupGetParam "p" p <- fromMaybe "" <$> lookupGetParam "p"
let opts = appOpts app ++ [Period p] let (a',p') = (unpack a, unpack p)
args = appArgs app ++ words' a opts = appOpts app ++ [Period p']
args = appArgs app ++ words' a'
fspec = optsToFilterSpec opts args t fspec = optsToFilterSpec opts args t
return (a, p, opts, fspec) return (a', p', opts, fspec)
-- | Quote-sensitive words, ie don't split on spaces which are inside quotes. -- | Quote-sensitive words, ie don't split on spaces which are inside quotes.
words' :: String -> [String] words' :: String -> [String]
@ -297,52 +321,52 @@ getHandlerData = do
else case jE of else case jE of
Right j' -> do liftIO $ putValue "hledger" "journal" j' Right j' -> do liftIO $ putValue "hledger" "journal" j'
return (j',Nothing) return (j',Nothing)
Left e -> do setMessage $ string "error while reading" {- ++ ": " ++ e-} Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-}
return (j, Just e) return (j, Just e)
-- | Helper to work around a yesod feature (can't set and get a message in the same request.) -- | Helper to work around a yesod feature (can't set and get a message in the same request.)
getMessage' :: Maybe String -> Handler (Maybe Html) getMessage' :: Maybe String -> Handler (Maybe Html)
getMessage' newmsgstr = do getMessage' newmsgstr = do
oldmsg <- getMessage oldmsg <- getMessage
return $ maybe oldmsg (Just . string) newmsgstr return $ maybe oldmsg (Just . toHtml) newmsgstr
-- | Wrap a template with the standard hledger web ui page layout. -- | Wrap a template with the standard hledger web ui page layout.
pageLayout :: TemplateData -> Hamlet AppRoute -> Hamlet AppRoute pageLayout :: TemplateData -> Hamlet AppRoute -> Hamlet AppRoute
pageLayout td@TD{title=basetitle, msg=msg, p=p, j=j, today=today} content = [$hamlet| pageLayout td@TD{title=basetitle, msg=msg, p=p, j=j, today=today} content = [$hamlet|
!!! !!!
%html <html
%head <head
%title $title'$ <title>#{title'}
%meta!http-equiv=Content-Type!content=$metacontent$ <meta http-equiv=Content-Type content=#{metacontent}
%script!type=text/javascript!src=@StaticR.jquery_js@ <script type=text/javascript src=@{StaticR jquery_js}
%script!type=text/javascript!src=@StaticR.jquery_url_js@ <script type=text/javascript src=@{StaticR jquery_url_js}
%script!type=text/javascript!src=@StaticR.dhtmlxcommon_js@ <script type=text/javascript src=@{StaticR dhtmlxcommon_js}
%script!type=text/javascript!src=@StaticR.dhtmlxcombo_js@ <script type=text/javascript src=@{StaticR dhtmlxcombo_js}
%script!type=text/javascript!src=@StaticR.hledger_js@ <script type=text/javascript src=@{StaticR hledger_js}
%link!rel=stylesheet!type=text/css!media=all!href=@StaticR.style_css@ <link rel=stylesheet type=text/css media=all href=@{StaticR style_css}
%body <body
^navbar.td^ ^{navbar td}
#messages $m$ <div#messages>#{m}
#content <div#content
^content^ ^{content}
|] |]
where title' = basetitle ++ " - " ++ journaltitle where title' = basetitle ++ " - " ++ journaltitle
(journaltitle, _) = journalTitleDesc j p today (journaltitle, _) = journalTitleDesc j p today
metacontent = "text/html; charset=utf-8" metacontent = "text/html; charset=utf-8" :: String
m = fromMaybe (string "") msg m = fromMaybe "" msg
-- | Global toolbar/heading area. -- | Global toolbar/heading area.
navbar :: TemplateData -> Hamlet AppRoute navbar :: TemplateData -> Hamlet AppRoute
navbar TD{p=p,j=j,today=today} = [$hamlet| navbar TD{p=p,j=j,today=today} = [$hamlet|
#navbar <div#navbar
%a.topleftlink!href=$hledgerorgurl$ <a.topleftlink href=#{hledgerorgurl}
hledger hledger
<br /> <br />
$version$ #{version}
%a.toprightlink!href=$manualurl$!target=hledgerhelp manual <a.toprightlink href=#{manualurl} target=hledgerhelp manual
%h1 $title$ <h1>#{title}
\ $ \ #
%span#journaldesc $desc$ <span#journaldesc>#{desc}
|] |]
where (title, desc) = journalTitleDesc j p today where (title, desc) = journalTitleDesc j p today
@ -360,73 +384,73 @@ journalTitleDesc j p today = (title, desc)
-- | Links to the main views. -- | Links to the main views.
navlinks :: TemplateData -> Hamlet AppRoute navlinks :: TemplateData -> Hamlet AppRoute
navlinks td = [$hamlet| navlinks td = [$hamlet|
#navlinks <div#navlinks
^accountsjournallink^ ^{accountsjournallink}
\ | $ \ | #
^accountsregisterlink^ ^{accountsregisterlink}
\ | $ \ | #
%a#addformlink!href!onclick="return addformToggle(event)" add transaction <a#addformlink href onclick="return addformToggle(event)">add transaction
%a#importformlink!href!onclick="return importformToggle(event)"!style=display:none; import transactions <a#importformlink href onclick="return importformToggle(event)" style="display:none;">import transactions
\ | $ \ | #
%a#editformlink!href!onclick="return editformToggle(event)" edit journal <a#editformlink href onclick="return editformToggle(event)">edit journal
|] |]
-- \ | $ -- \ | #
where where
accountsjournallink = navlink td "journal" JournalR accountsjournallink = navlink td "journal" JournalR
accountsregisterlink = navlink td "register" RegisterR accountsregisterlink = navlink td "register" RegisterR
navlink :: TemplateData -> String -> AppRoute -> Hamlet AppRoute navlink :: TemplateData -> String -> AppRoute -> Hamlet AppRoute
navlink TD{here=here,a=a,p=p} s dest = [$hamlet|%a#$s$link.$style$!href=@?u@ $s$|] navlink TD{here=here,a=a,p=p} s dest = [$hamlet|<a##{s}link.#{style} href=@?{u}>#{s}</a>|]
where u = (dest, concat [(if null a then [] else [("a", a)]) where u = (dest, concat [(if null a then [] else [("a", pack a)])
,(if null p then [] else [("p", p)])]) ,(if null p then [] else [("p", pack p)])])
style | dest == here = "navlinkcurrent" style | dest == here = "navlinkcurrent"
| otherwise = "navlink" | otherwise = "navlink" :: Text
-- | Form controlling journal filtering parameters. -- | Form controlling journal filtering parameters.
filterform :: TemplateData -> Hamlet AppRoute filterform :: TemplateData -> Hamlet AppRoute
filterform TD{here=here,a=a,p=p} = [$hamlet| filterform TD{here=here,a=a,p=p} = [$hamlet|
#filterformdiv <div#filterformdiv
%form#filterform.form!method=GET!style=display:$visible$; <form#filterform.form method=GET style=display:#{visible};
%table.form <table.form
%tr.$filteringperiodclass$ <tr.#{filteringperiodclass}
%td <td
filter by period: filter by period:
\ $ \ #
%td <td
%input!name=p!size=60!value=$p$ <input name=p size=60 value=#{p}
^phelp^ ^{phelp}
\ $ \ #
%td!align=right <td align=right
^stopfilteringperiod^ ^{stopfilteringperiod}
%tr.$filteringclass$ <tr.#{filteringclass}
%td <td
filter by account/description: filter by account/description:
\ $ \ #
%td <td
%input!name=a!size=60!value=$a$ <input name=a size=60 value=#{a}
^ahelp^ ^{ahelp}
\ $ \ #
%input!type=submit!value=filter $ <input type=submit value=filter #
\ $ \ #
%td!align=right <td align=right
^stopfiltering^ ^{stopfiltering}
|] |]
where where
ahelp = helplink "filter-patterns" "?" ahelp = helplink "filter-patterns" "?"
phelp = helplink "period-expressions" "?" phelp = helplink "period-expressions" "?"
filtering = not $ null a filtering = not $ null a
filteringperiod = not $ null p filteringperiod = not $ null p
visible = "block" visible = "block" :: String
filteringclass = if filtering then "filtering" else "" filteringclass = if filtering then "filtering" else "" :: String
filteringperiodclass = if filteringperiod then "filtering" else "" filteringperiodclass = if filteringperiod then "filtering" else "" :: String
stopfiltering = if filtering then [$hamlet|%a#stopfilterlink!href=@?u@ clear filter|] else nulltemplate stopfiltering = if filtering then [$hamlet|<a#stopfilterlink href=@?{u} clear filter|] else nulltemplate
where u = (here, if filteringperiod then [("p", p)] else []) where u = (here, if filteringperiod then [("p", pack p)] else [])
stopfilteringperiod = if filteringperiod then [$hamlet|%a#stopfilterlink!href=@?u@ clear filter|] else nulltemplate stopfilteringperiod = if filteringperiod then [$hamlet|<a#stopfilterlink href=@?{u} clear filter|] else nulltemplate
where u = (here, if filtering then [("a", a)] else []) where u = (here, if filtering then [("a", pack a)] else [])
-- | Link to a topic in the manual. -- | Link to a topic in the manual.
helplink :: String -> String -> Hamlet AppRoute helplink :: String -> String -> Hamlet AppRoute
helplink topic label = [$hamlet|%a!href=$u$!target=hledgerhelp $label$|] helplink topic label = [$hamlet|<a href=#{u} target=hledgerhelp>#{label}|]
where u = manualurl ++ if null topic then "" else '#':topic where u = manualurl ++ if null topic then "" else '#':topic
{- {-
@ -521,17 +545,17 @@ getJournalR = do
td = mktd{here=here, title="hledger journal", msg=msg, a=a, p=p, j=j, today=today} td = mktd{here=here, title="hledger journal", msg=msg, a=a, p=p, j=j, today=today}
editform' = editform td editform' = editform td
hamletToRepHtml $ pageLayout td [$hamlet| hamletToRepHtml $ pageLayout td [$hamlet|
%div#content <div#content
%div#sidebar <div#sidebar
^sidecontent^ ^{sidecontent}
%div#main.journal <div#main.journal
^navlinks.td^ ^{navlinks td}
%div#transactions <div#transactions
^filterform.td^ ^{filterform td}
^maincontent^ ^{maincontent}
^addform.td^ ^{addform td}
^editform'^ ^{editform'}
^importform^ ^{importform}
|] |]
postJournalR :: Handler RepPlain postJournalR :: Handler RepPlain
@ -554,17 +578,17 @@ getRegisterR = do
td = mktd{here=here, title="hledger register", msg=msg, a=a, p=p, j=j, today=today} td = mktd{here=here, title="hledger register", msg=msg, a=a, p=p, j=j, today=today}
editform' = editform td editform' = editform td
hamletToRepHtml $ pageLayout td [$hamlet| hamletToRepHtml $ pageLayout td [$hamlet|
%div#content <div#content
%div#sidebar <div#sidebar
^sidecontent^ ^{sidecontent}
%div#main.journal <div#main.journal
^navlinks.td^ ^{navlinks td}
%div#transactions <div#transactions
^filterform.td^ ^{filterform td}
^maincontent^ ^{maincontent}
^addform.td^ ^{addform td}
^editform'^ ^{editform'}
^importform^ ^{importform}
|] |]
postRegisterR :: Handler RepPlain postRegisterR :: Handler RepPlain
@ -583,57 +607,57 @@ getAccountsOnlyR = do
-- | Render a balance report as HTML. -- | Render a balance report as HTML.
balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Hamlet AppRoute balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Hamlet AppRoute
balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet| balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet|
^accountsheading^ ^{accountsheading}
%table.balancereport <table.balancereport>
$forall items i $forall i <- items
^itemAsHtml' i^ ^{itemAsHtml' i}
%tr.totalrule <tr.totalrule>
%td!colspan=2 <td colspan=2>
%tr <tr>
%td <td>
%td!align=right $mixedAmountAsHtml.total$ <td align=right>#{mixedAmountAsHtml total} >
|] |]
where where
accountsheading = [$hamlet| accountsheading = [$hamlet|
#accountsheading <div#accountsheading
accounts accounts
\ $ \ #
^showlinks^ ^{showlinks}
|] |] :: Hamlet AppRoute
where where
filteringaccts = not $ null a filteringaccts = not $ null a
showlinks = [$hamlet|%span#showmoreaccounts ^showmore^ ^showall^|] showlinks = [$hamlet|<span#showmoreaccounts ^{showmore} ^{showall}|] :: Hamlet AppRoute
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",a''), ("p",p)]) parenturl = (here, [("a",pack a''), ("p",pack p)])
in [$hamlet| in [$hamlet|
\ | $ \ | #
%a!href=@?parenturl@ show more &uarr; <a href=@?{parenturl} show more &uarr;
|] |]
_ -> nulltemplate _ -> nulltemplate
showall = if filteringaccts showall = if filteringaccts
then [$hamlet| then [$hamlet|
\ | $ \ | #
%a!href=@?allurl@ show all <a href=@?{allurl} show all
|] |]
else nulltemplate else nulltemplate
where allurl = (here, [("p",p)]) where allurl = (here, [("p",pack p)])
itemAsHtml' = itemAsHtml td itemAsHtml' = itemAsHtml td
itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet AppRoute itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet AppRoute
itemAsHtml TD{p=p} (acct, adisplay, adepth, abal) = [$hamlet| itemAsHtml TD{p=p} (acct, adisplay, adepth, abal) = [$hamlet|
%tr.item <tr.item
%td.account <td.account
$indent$ #{indent}
%a!href=$aurl$ $adisplay$ <a href=#{aurl}>#{adisplay}
%td.balance!align=right $mixedAmountAsHtml.abal$ <td.balance align=right>#{mixedAmountAsHtml abal}
|] where |] where
-- current = if not (null a) && containsRegex a acct then "current" else "" -- current = if not (null a) && containsRegex a acct then "current" else ""
indent = preEscapedString $ concat $ replicate (2 * adepth) "&nbsp;" indent = preEscapedString $ concat $ replicate (2 * adepth) "&nbsp;"
aurl = printf ".?a=%s%s" (accountNameToAccountRegex acct) p' :: String aurl = printf ".?a=%s%s" (accountNameToAccountRegex acct) p' :: String
p' = if null p then "" else printf "&p=%s" p p' = if null p then "" else printf "&p=%s" p :: String
accountNameToAccountRegex :: String -> String accountNameToAccountRegex :: String -> String
accountNameToAccountRegex "" = "" accountNameToAccountRegex "" = ""
@ -656,39 +680,39 @@ getJournalOnlyR = do
editform' = editform td editform' = editform td
txns = journalReportAsHtml opts td $ journalReport opts fspec j txns = journalReportAsHtml opts td $ journalReport opts fspec j
hamletToRepHtml $ pageLayout td [$hamlet| hamletToRepHtml $ pageLayout td [$hamlet|
%div#journal <div#journal
%div.nav2 <div.nav2
%a#addformlink!href!onclick="return addformToggle(event)" add one transaction <a#addformlink href onclick="return addformToggle(event)" add one transaction
\ | $ \ | #
%a#editformlink!href!onclick="return editformToggle(event)" edit the whole journal <a#editformlink href onclick="return editformToggle(event)" edit the whole journal
#transactions ^txns^ <div#transactions ^{txns}
^addform.td^ ^{addform td}
^editform'^ ^{editform'}
|] |]
-- | Render a journal report as HTML. -- | Render a journal report as HTML.
journalReportAsHtml :: [Opt] -> TemplateData -> JournalReport -> Hamlet AppRoute journalReportAsHtml :: [Opt] -> TemplateData -> JournalReport -> Hamlet AppRoute
journalReportAsHtml _ td items = [$hamlet| journalReportAsHtml _ td items = [$hamlet|
%table.journalreport <table.journalreport>
$forall number.items i $forall i <- number items
^itemAsHtml' i^ ^{itemAsHtml' i}
|] |]
where where
number = zip [1..] number = zip [1..]
itemAsHtml' = itemAsHtml td itemAsHtml' = itemAsHtml td
itemAsHtml :: TemplateData -> (Int, JournalReportItem) -> Hamlet AppRoute itemAsHtml :: TemplateData -> (Int, JournalReportItem) -> Hamlet AppRoute
itemAsHtml _ (n, t) = [$hamlet| itemAsHtml _ (n, t) = [$hamlet|
%tr.item.$evenodd$ <tr.item.#{evenodd} >
%td.transaction <td.transaction>
%pre $txn$ <pre> #{txn}
|] where |] where
evenodd = if even n then "even" else "odd" evenodd = if even n then "even" else "odd" :: String
txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse
addform :: TemplateData -> Hamlet AppRoute addform :: TemplateData -> Hamlet AppRoute
addform td = [$hamlet| addform td = [$hamlet|
%script!type=text/javascript <script type=text/javascript>
$$(document).ready(function() { $(document).ready(function() {
/* dhtmlxcombo setup */ /* dhtmlxcombo setup */
window.dhx_globalImgPath="../static/"; window.dhx_globalImgPath="../static/";
var desccombo = new dhtmlXCombo("description"); var desccombo = new dhtmlXCombo("description");
@ -703,50 +727,50 @@ addform td = [$hamlet|
/* desccombo.enableOptionAutoHeight(true, 20); */ /* desccombo.enableOptionAutoHeight(true, 20); */
/* desccombo.setOptionHeight(200); */ /* desccombo.setOptionHeight(200); */
}); });
%form#addform!method=POST!style=display:none; <form#addform method=POST style=display:none;
%table.form <table.form
%tr <tr
%td!colspan=4 <td colspan=4
%table <table
%tr#descriptionrow <tr#descriptionrow
%td <td
Date: Date:
%td <td
%input.textinput!size=15!name=date!value=$date$ <input.textinput size=15 name=date value=#{date}
%td!style=padding-left:1em; <td style=padding-left:1em;
Description: Description:
%td <td
%select!id=description!name=description <select id=description name=description
%option <option
$forall descriptions d $forall d <- descriptions
%option!value=$d$ $d$ <option value=#{d}>#{d}
%tr.helprow <tr.helprow
%td <td
%td <td
.help $datehelp$ $ <span.help>#{datehelp} #
%td <td
%td <td
.help $deschelp$ <span.help>#{deschelp}
^postingsfields.td^ ^{postingsfields td}
%tr#addbuttonrow <tr#addbuttonrow
%td!colspan=4 <td colspan=4
%input!type=hidden!name=action!value=add <input type=hidden name=action value=add
%input!type=submit!name=submit!value="add transaction" <input type=submit name=submit value="add transaction"
$if manyfiles $if manyfiles
\ to: ^journalselect.files.j.td^ \ to: ^{journalselect $ files $ j td}
|] |]
where where
-- datehelplink = helplink "dates" "..." -- datehelplink = helplink "dates" "..."
datehelp = "eg: 2010/7/20" datehelp = "eg: 2010/7/20" :: String
deschelp = "eg: supermarket (optional)" deschelp = "eg: supermarket (optional)" :: String
date = "today" date = "today" :: String
descriptions = sort $ nub $ map tdescription $ jtxns $ j td descriptions = sort $ nub $ map tdescription $ jtxns $ j td
manyfiles = (length $ files $ j td) > 1 manyfiles = (length $ files $ j td) > 1
postingsfields :: TemplateData -> Hamlet AppRoute postingsfields :: TemplateData -> Hamlet AppRoute
postingsfields td = [$hamlet| postingsfields td = [$hamlet|
^p1^ ^{p1}
^p2^ ^{p2}
|] |]
where where
p1 = postingfields td 1 p1 = postingfields td 1
@ -754,21 +778,21 @@ postingsfields td = [$hamlet|
postingfields :: TemplateData -> Int -> Hamlet AppRoute postingfields :: TemplateData -> Int -> Hamlet AppRoute
postingfields TD{j=j} n = [$hamlet| postingfields TD{j=j} n = [$hamlet|
%tr#postingrow <tr#postingrow
%td!align=right $acctlabel$: <td align=right>#{acctlabel}:
%td <td
%select!id=$acctvar$!name=$acctvar$ <select id=#{acctvar} name=#{acctvar}
%option <option
$forall acctnames a $forall a <- acctnames
%option!value=$a$ $a$ <option value=#{a}>#{a}
^amtfield^ ^{amtfield}
%tr.helprow <tr.helprow
%td <td
%td <td
.help $accthelp$ <span.help>#{accthelp}
%td <td
%td <td
.help $amthelp$ <span.help>#{amthelp}
|] |]
where where
numbered = (++ show n) numbered = (++ show n)
@ -779,41 +803,41 @@ postingfields TD{j=j} n = [$hamlet|
| n == 1 = ("To account" | n == 1 = ("To account"
,"eg: expenses:food" ,"eg: expenses:food"
,[$hamlet| ,[$hamlet|
%td!style=padding-left:1em; <td style=padding-left:1em;
Amount: Amount:
%td <td
%input.textinput!size=15!name=$amtvar$!value="" <input.textinput size=15 name=#{amtvar} value=""
|] |]
,"eg: $6" ,"eg: $6"
) )
| otherwise = ("From account" | otherwise = ("From account" :: String
,"eg: assets:bank:checking" ,"eg: assets:bank:checking" :: String
,nulltemplate ,nulltemplate
,"" ,"" :: String
) )
editform :: TemplateData -> Hamlet AppRoute editform :: TemplateData -> Hamlet AppRoute
editform TD{j=j} = [$hamlet| editform TD{j=j} = [$hamlet|
%form#editform!method=POST!style=display:none; <form#editform method=POST style=display:none;
%table.form#editform <table.form#editform
$if manyfiles $if manyfiles
%tr <tr
%td!colspan=2 <td colspan=2
Editing ^journalselect.files.j^ Editing ^{journalselect $ files j}
%tr <tr
%td!colspan=2 <td colspan=2
$forall files.j f $forall f <- files j
%textarea!id=$fst.f$_textarea!name=text!rows=25!cols=80!style=display:none;!disabled=disabled <textarea id=#{fst f}_textarea name=text rows=25 cols=80 style=display:none; disabled=disabled
$snd.f$ #{snd f}
%tr#addbuttonrow <tr#addbuttonrow
%td <td
%span.help ^formathelp^ <span.help ^{formathelp}
%td!align=right <td align=right
%span.help Are you sure ? This will overwrite the journal. $ <span.help Are you sure ? This will overwrite the journal. #
%input!type=hidden!name=action!value=edit <input type=hidden name=action value=edit
%input!type=submit!name=submit!value="save journal" <input type=submit name=submit value="save journal"
\ or $ \ or #
%a!href!onclick="return editformToggle(event)" cancel <a href onclick="return editformToggle(event)">cancel
|] -- XXX textarea ids are unquoted journal file paths, which is not valid html |] -- XXX textarea ids are unquoted journal file paths, which is not valid html
where where
manyfiles = (length $ files j) > 1 manyfiles = (length $ files j) > 1
@ -821,22 +845,22 @@ editform TD{j=j} = [$hamlet|
journalselect :: [(FilePath,String)] -> Hamlet AppRoute journalselect :: [(FilePath,String)] -> Hamlet AppRoute
journalselect journalfiles = [$hamlet| journalselect journalfiles = [$hamlet|
%select!id=journalselect!name=journal!onchange="editformJournalSelect(event)" <select id=journalselect name=journal onchange="editformJournalSelect(event)"
$forall journalfiles f $forall f <- journalfiles
%option!value=$fst.f$ $fst.f$ <option value=#{fst f}>#{fst f}
|] |]
importform :: Hamlet AppRoute importform :: Hamlet AppRoute
importform = [$hamlet| importform = [$hamlet|
%form#importform!method=POST!style=display:none; <form#importform method=POST style=display:none;
%table.form <table.form
%tr <tr
%td <td
%input!type=file!name=file <input type=file name=file
%input!type=hidden!name=action!value=import <input type=hidden name=action value=import
%input!type=submit!name=submit!value="import from file" <input type=submit name=submit value="import from file"
\ or $ \ or #
%a!href!onclick="return importformToggle(event)" cancel <a href onclick="return importformToggle(event)" cancel
|] |]
postJournalOnlyR :: Handler RepPlain postJournalOnlyR :: Handler RepPlain
@ -862,16 +886,18 @@ postAddForm = do
<*> maybeStringInput "amount2" <*> maybeStringInput "amount2"
<*> maybeStringInput "journal" <*> maybeStringInput "journal"
-- supply defaults and parse date and amounts, or get errors. -- supply defaults and parse date and amounts, or get errors.
let dateE = maybe (Left "date required") (either (\e -> Left $ showDateParseError e) Right . fixSmartDateStrEither today) dateM let dateE = maybe (Left "date required") (either (\e -> Left $ showDateParseError e) Right . fixSmartDateStrEither today . unpack) dateM
descE = Right $ fromMaybe "" descM descE = Right $ maybe "" unpack descM
acct1E = maybe (Left "to account required") Right acct1M acct1E = maybe (Left "to account required") (Right . unpack) acct1M
acct2E = maybe (Left "from account required") Right acct2M acct2E = maybe (Left "from account required") (Right . unpack) acct2M
amt1E = maybe (Left "amount required") (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx someamount) amt1M amt1E = maybe (Left "amount required") (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx someamount . unpack) amt1M
amt2E = maybe (Right missingamt) (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx someamount) amt2M amt2E = maybe (Right missingamt) (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx someamount . unpack) amt2M
journalE = maybe (Right $ journalFilePath j) journalE = maybe (Right $ journalFilePath j)
(\f -> if f `elem` journalFilePaths j (\f -> let f' = unpack f in
then Right f if f' `elem` journalFilePaths j
else Left $ "unrecognised journal file path: " ++ f) then Right f'
else Left $ "unrecognised journal file path: " ++ f'
)
journalM journalM
strEs = [dateE, descE, acct1E, acct2E, journalE] strEs = [dateE, descE, acct1E, acct2E, journalE]
amtEs = [amt1E, amt2E] amtEs = [amt1E, amt2E]
@ -893,13 +919,13 @@ postAddForm = do
case tE of case tE of
Left errs -> do Left errs -> do
-- save current form values in session -- save current form values in session
setMessage $ string $ intercalate "; " errs setMessage $ toHtml $ intercalate "; " errs
redirect RedirectTemporary RegisterR redirect RedirectTemporary RegisterR
Right t -> do Right t -> do
let t' = txnTieKnot t -- XXX move into balanceTransaction let t' = txnTieKnot t -- XXX move into balanceTransaction
liftIO $ appendToJournalFile journalpath $ showTransaction t' liftIO $ appendToJournalFile journalpath $ showTransaction t'
setMessage $ string $ printf "Added transaction:\n%s" (show t') setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String)
redirect RedirectTemporary RegisterR redirect RedirectTemporary RegisterR
-- | Handle a journal edit form post. -- | Handle a journal edit form post.
@ -912,10 +938,11 @@ postEditForm = do
$ (,) $ (,)
<$> maybeStringInput "text" <$> maybeStringInput "text"
<*> maybeStringInput "journal" <*> maybeStringInput "journal"
let textE = maybe (Left "No value provided") Right textM let textE = maybe (Left "No value provided") (Right . unpack) textM
journalE = maybe (Right $ journalFilePath j) journalE = maybe (Right $ journalFilePath j)
(\f -> if f `elem` journalFilePaths j (\f -> let f' = unpack f in
then Right f if f' `elem` journalFilePaths j
then Right f'
else Left "unrecognised journal file path") else Left "unrecognised journal file path")
journalM journalM
strEs = [textE, journalE] strEs = [textE, journalE]
@ -924,7 +951,7 @@ postEditForm = do
-- display errors or perform edit -- display errors or perform edit
if not $ null errs if not $ null errs
then do then do
setMessage $ string $ intercalate "; " errs setMessage $ toHtml (intercalate "; " errs :: String)
redirect RedirectTemporary JournalR redirect RedirectTemporary JournalR
else do else do
@ -935,24 +962,24 @@ postEditForm = do
changed = tnew /= told || filechanged' changed = tnew /= told || filechanged'
if not changed if not changed
then do then do
setMessage $ string $ "No change" setMessage "No change"
redirect RedirectTemporary JournalR redirect RedirectTemporary JournalR
else do else do
jE <- liftIO $ journalFromPathAndString Nothing journalpath tnew jE <- liftIO $ journalFromPathAndString Nothing journalpath tnew
either either
(\e -> do (\e -> do
setMessage $ string e setMessage $ toHtml e
redirect RedirectTemporary JournalR) redirect RedirectTemporary JournalR)
(const $ do (const $ do
liftIO $ writeFileWithBackup journalpath tnew liftIO $ writeFileWithBackup journalpath tnew
setMessage $ string $ printf "Saved journal %s\n" (show journalpath) setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String)
redirect RedirectTemporary JournalR) redirect RedirectTemporary JournalR)
jE jE
-- | Handle an import page post. -- | Handle an import page post.
postImportForm :: Handler RepPlain postImportForm :: Handler RepPlain
postImportForm = do postImportForm = do
setMessage $ string $ "can't handle file upload yet" setMessage "can't handle file upload yet"
redirect RedirectTemporary JournalR redirect RedirectTemporary JournalR
-- -- get form input values, or basic validation errors. E means an Either value. -- -- get form input values, or basic validation errors. E means an Either value.
-- fileM <- runFormPost' $ maybeFileInput "file" -- fileM <- runFormPost' $ maybeFileInput "file"
@ -960,11 +987,11 @@ postImportForm = do
-- -- display errors or import transactions -- -- display errors or import transactions
-- case fileE of -- case fileE of
-- Left errs -> do -- Left errs -> do
-- setMessage $ string errs -- setMessage errs
-- redirect RedirectTemporary JournalR -- redirect RedirectTemporary JournalR
-- Right s -> do -- Right s -> do
-- setMessage $ string $ s -- setMessage s
-- redirect RedirectTemporary JournalR -- redirect RedirectTemporary JournalR
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -980,41 +1007,41 @@ getRegisterOnlyR = do
-- | Render a register report as HTML. -- | Render a register report as HTML.
registerReportAsHtml :: [Opt] -> TemplateData -> RegisterReport -> Hamlet AppRoute registerReportAsHtml :: [Opt] -> TemplateData -> RegisterReport -> Hamlet AppRoute
registerReportAsHtml _ td items = [$hamlet| registerReportAsHtml _ td items = [$hamlet|
%table.registerreport <table.registerreport
%tr.headings <tr.headings
^headings^ ^{headings}
$forall number.items i $forall i <- number items
^itemAsHtml' i^ ^{itemAsHtml' i}
|] |]
where where
number = zip [1..] number = zip [1..]
headings = [$hamlet| headings = [$hamlet|
%th.date!align=left Date <th.date align=left Date
%th.description!align=left Description <th.description align=left Description
%th.account!align=left Account <th.account align=left Account
%th.amount!align=right Amount <th.amount align=right Amount
%th.balance!align=right Balance <th.balance align=right Balance
|] |] :: Hamlet AppRoute
itemAsHtml' = itemAsHtml td itemAsHtml' = itemAsHtml td
itemAsHtml :: TemplateData -> (Int, RegisterReportItem) -> Hamlet AppRoute itemAsHtml :: TemplateData -> (Int, RegisterReportItem) -> Hamlet AppRoute
itemAsHtml TD{p=p} (n, (ds, posting, b)) = [$hamlet| itemAsHtml TD{p=p} (n, (ds, posting, b)) = [$hamlet|
%tr.item.$evenodd$.$firstposting$ <tr.item.#{evenodd}.#{firstposting}
%td.date $date$ <td.date>#{date}
%td.description $desc$ <td.description>#{desc}
%td.account <td.account
%a!href=$aurl$ $acct$ <a href=#{aurl}>#{acct}
%td.amount!align=right $mixedAmountAsHtml.pamount.posting$ <td.amount align=right>#{mixedAmountAsHtml $ pamount posting}
%td.balance!align=right $mixedAmountAsHtml.b$ <td.balance align=right>#{mixedAmountAsHtml b}
|] where |] where
evenodd = if even n then "even" else "odd" 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 -> ("", "", "") Nothing -> ("", "", "") :: (String,String,String)
acct = paccount posting acct = paccount posting
aurl = printf ".?a=%s%s" (accountNameToAccountRegex acct) p' :: String aurl = printf ".?a=%s%s" (accountNameToAccountRegex acct) p' :: String
p' = if null p then "" else printf "&p=%s" p p' = if null p then "" else printf "&p=%s" p :: String
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 where addclass = printf "<span class=\"%s\">%s</span>" (c :: String)
c = case isNegativeMixedAmount b of Just True -> "negative amount" c = case isNegativeMixedAmount b of Just True -> "negative amount"
_ -> "positive amount" _ -> "positive amount"
@ -1058,10 +1085,10 @@ getAddformRTR = do
| n == 1 = ("To account" | n == 1 = ("To account"
,"eg: expenses:food" ,"eg: expenses:food"
,[$hamlet| ,[$hamlet|
%td!style=padding-left:1em; %td style=padding-left:1em;
Amount: Amount:
%td %td
%input.textinput!size=15!name=$amtvar$!value="" %input.textinput size=15 name=$amtvar$ value=""
|] |]
,"eg: $6" ,"eg: $6"
) )

16
hledger-web/Hledger/Web/Main.hs
View File

@ -8,12 +8,12 @@ Released under GPL version 3 or later.
module Hledger.Web.Main where module Hledger.Web.Main where
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Network.Wai.Handler.SimpleServer (run) import Data.Text(pack)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.IO.Storage (withStore, putValue,) import System.IO.Storage (withStore, putValue,)
import Yesod.Content (typeByExt)
import Yesod.Helpers.Static (fileLookupDir)
import System.Console.GetOpt import System.Console.GetOpt
import Yesod
import Yesod.Helpers.Static
import Hledger.Cli.Options import Hledger.Cli.Options
import Hledger.Cli.Utils (withJournalDo, openBrowserOn) import Hledger.Cli.Utils (withJournalDo, openBrowserOn)
@ -21,7 +21,7 @@ import Hledger.Cli.Version (progversionstr, binaryfilename)
import Hledger.Data import Hledger.Data
import Prelude hiding (putStr, putStrLn) import Prelude hiding (putStr, putStrLn)
import Hledger.Data.UTF8 (putStr, putStrLn) import Hledger.Data.UTF8 (putStr, putStrLn)
import Hledger.Web.App (App(..), withApp) import Hledger.Web.App (App(..))
import Hledger.Web.Files (createFilesIfMissing) import Hledger.Web.Files (createFilesIfMissing)
import Hledger.Web.Settings (browserstartdelay, defhost, defport, datadir) import Hledger.Web.Settings (browserstartdelay, defhost, defport, datadir)
@ -82,15 +82,15 @@ server baseurl port opts args j = do
printf "Starting http server on port %d with base url %s\n" port baseurl printf "Starting http server on port %d with base url %s\n" port baseurl
withStore "hledger" $ do withStore "hledger" $ do
putValue "hledger" "journal" j putValue "hledger" "journal" j
withApp App{ warpDebug port $ App{
-- appConnPool=Nothing -- appConnPool=Nothing
appRoot=baseurl appRoot=pack baseurl
,appDataDir=datadir ,appDataDir=datadir
,appStatic=fileLookupDir datadir $ typeByExt -- ++[("hamlet","text/plain")] ,appStaticSettings=static datadir
,appOpts=opts ,appOpts=opts
,appArgs=args ,appArgs=args
,appJournal=j ,appJournal=j
} $ run port }
browser :: String -> IO () browser :: String -> IO ()
browser baseurl = do browser baseurl = do

9
hledger-web/Hledger/Web/Settings.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, OverloadedStrings #-}
module Hledger.Web.Settings module Hledger.Web.Settings
( (
hamletFile hamletFile
@ -42,17 +42,18 @@ browserstartdelay = 100000 -- microseconds
-- urls -- urls
---------------------------------------------------------------------- ----------------------------------------------------------------------
hledgerorgurl, manualurl :: String
hledgerorgurl = "http://hledger.org" hledgerorgurl = "http://hledger.org"
manualurl = hledgerorgurl++"/MANUAL.html" manualurl = hledgerorgurl++"/MANUAL.html"
defhost = "localhost" defhost = "localhost" :: String
defport = 5000 defport = 5000
approot :: String approot :: String
#ifdef PRODUCTION #ifdef PRODUCTION
approot = printf "http://%s:%d" defhost (defport :: Int) approot = printf "http://%s:%d" defhost (defport :: Int) :: String
#else #else
approot = printf "http://%s:%d" defhost (defport :: Int) approot = printf "http://%s:%d" defhost (defport :: Int) :: String
#endif #endif
staticroot :: String staticroot :: String

5
hledger-web/hledger-web.cabal
View File

@ -68,13 +68,12 @@ executable hledger-web
-- ,time -- ,time
-- ,utf8-string >= 0.3.5 && < 0.4 -- ,utf8-string >= 0.3.5 && < 0.4
,io-storage >= 0.3 && < 0.4 ,io-storage >= 0.3 && < 0.4
,yesod >= 0.6.1.2 && < 0.7 ,yesod >= 0.8 && < 0.9
,hamlet >= 0.6.0.1 && < 0.7
-- ,convertible-text >= 0.3.0.1 && < 0.4 -- ,convertible-text >= 0.3.0.1 && < 0.4
-- ,data-object >= 0.3.1.2 && < 0.4 -- ,data-object >= 0.3.1.2 && < 0.4
,failure >= 0.1 && < 0.2 ,failure >= 0.1 && < 0.2
-- ,persistent == 0.2.* -- ,persistent == 0.2.*
-- ,persistent-sqlite == 0.2.* -- ,persistent-sqlite == 0.2.*
,template-haskell >= 2.4 && < 2.6 ,template-haskell >= 2.4 && < 2.6
,wai-extra == 0.2.* ,wai-extra == 0.4.*
,file-embed == 0.0.* ,file-embed == 0.0.*