443 lines
14 KiB
Haskell
443 lines
14 KiB
Haskell
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-}
|
|
{-|
|
|
A web-based UI.
|
|
-}
|
|
|
|
module Hledger.Cli.Commands.Web
|
|
where
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Applicative ((<$>), (<*>))
|
|
import Data.Either
|
|
import System.FilePath ((</>))
|
|
import System.IO.Storage (withStore, putValue, getValue)
|
|
import Text.ParserCombinators.Parsec (parse)
|
|
import Yesod
|
|
|
|
import Hledger.Cli.Commands.Add (journalAddTransaction)
|
|
import Hledger.Cli.Commands.Balance
|
|
import Hledger.Cli.Commands.Print
|
|
import Hledger.Cli.Commands.Register
|
|
import Hledger.Cli.Options hiding (value)
|
|
import Hledger.Cli.Utils
|
|
import Hledger.Data
|
|
import Hledger.Read (journalFromPathAndString)
|
|
import Hledger.Read.Journal (someamount)
|
|
#ifdef MAKE
|
|
import Paths_hledger_make (getDataFileName)
|
|
#else
|
|
import Paths_hledger (getDataFileName)
|
|
#endif
|
|
|
|
|
|
defhost = "localhost"
|
|
defport = 5000
|
|
defbaseurl = printf "http://%s:%d" defhost defport :: String
|
|
browserstartdelay = 100000 -- microseconds
|
|
hledgerurl = "http://hledger.org"
|
|
manualurl = hledgerurl++"/MANUAL.html"
|
|
|
|
web :: [Opt] -> [String] -> Journal -> IO ()
|
|
web opts args j = do
|
|
let baseurl = fromMaybe defbaseurl $ baseUrlFromOpts opts
|
|
port = fromMaybe defport $ portFromOpts opts
|
|
unless (Debug `elem` opts) $ forkIO (browser baseurl) >> return ()
|
|
server baseurl port opts args j
|
|
|
|
browser :: String -> IO ()
|
|
browser baseurl = do
|
|
putStrLn "starting web browser"
|
|
threadDelay browserstartdelay
|
|
openBrowserOn baseurl
|
|
return ()
|
|
|
|
server :: String -> Int -> [Opt] -> [String] -> Journal -> IO ()
|
|
server baseurl port opts args j = do
|
|
printf "starting web server on port %d with base url %s\n" port baseurl
|
|
fp <- getDataFileName "web"
|
|
let app = HledgerWebApp{
|
|
appOpts=opts
|
|
,appArgs=args
|
|
,appJournal=j
|
|
,appWebdir=fp
|
|
,appRoot=baseurl
|
|
}
|
|
withStore "hledger" $ do
|
|
putValue "hledger" "journal" j
|
|
basicHandler port app
|
|
|
|
data HledgerWebApp = HledgerWebApp {
|
|
appOpts::[Opt]
|
|
,appArgs::[String]
|
|
,appJournal::Journal
|
|
,appWebdir::FilePath
|
|
,appRoot::String
|
|
}
|
|
|
|
mkYesod "HledgerWebApp" [$parseRoutes|
|
|
/ IndexPage GET
|
|
/style.css StyleCss GET
|
|
/journal JournalPage GET POST
|
|
/edit EditPage GET POST
|
|
/register RegisterPage GET
|
|
/balance BalancePage GET
|
|
|]
|
|
|
|
instance Yesod HledgerWebApp where approot = appRoot
|
|
|
|
getIndexPage :: Handler HledgerWebApp ()
|
|
getIndexPage = redirect RedirectTemporary JournalPage
|
|
|
|
getStyleCss :: Handler HledgerWebApp ()
|
|
getStyleCss = do
|
|
app <- getYesod
|
|
let dir = appWebdir app
|
|
sendFile "text/css" $ dir </> "style.css"
|
|
|
|
getJournalPage :: Handler HledgerWebApp RepHtml
|
|
getJournalPage = withLatestJournalRender (const showTransactions)
|
|
|
|
getRegisterPage :: Handler HledgerWebApp RepHtml
|
|
getRegisterPage = withLatestJournalRender showRegisterReport
|
|
|
|
getBalancePage :: Handler HledgerWebApp RepHtml
|
|
getBalancePage = withLatestJournalRender showBalanceReport
|
|
|
|
withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
|
|
withLatestJournalRender reportfn = do
|
|
app <- getYesod
|
|
t <- liftIO $ getCurrentLocalTime
|
|
a <- fromMaybe "" <$> lookupGetParam "a"
|
|
p <- fromMaybe "" <$> lookupGetParam "p"
|
|
let opts = appOpts app ++ [Period p]
|
|
args = appArgs app ++ [a]
|
|
fspec = optsToFilterSpec opts args t
|
|
-- reload journal if changed, displaying any error as a message
|
|
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
|
(jE, changed) <- liftIO $ journalReloadIfChanged opts j
|
|
let (j', err) = either (\e -> (j,e)) (\j -> (j,"")) jE
|
|
when (changed && null err) $ liftIO $ putValue "hledger" "journal" j'
|
|
if (changed && not (null err)) then setMessage $ string "error while reading"
|
|
else return ()
|
|
-- run the specified report using this request's params
|
|
let s = reportfn opts fspec j'
|
|
-- render the standard template
|
|
msg' <- getMessage
|
|
-- XXX work around a bug, can't get the message we set above
|
|
let msg = if null err then msg' else Just $ string $ printf "Error while reading %s" (filepath j')
|
|
Just here <- getCurrentRoute
|
|
hamletToRepHtml $ template here msg a p "hledger" s
|
|
|
|
template :: HledgerWebAppRoute -> Maybe (Html ()) -> String -> String
|
|
-> String -> String -> Hamlet HledgerWebAppRoute
|
|
template here msg a p title content = [$hamlet|
|
|
!!!
|
|
%html
|
|
%head
|
|
%title $string.title$
|
|
%meta!http-equiv=Content-Type!content=$string.metacontent$
|
|
%link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
|
|
%body
|
|
^navbar'^
|
|
#messages $m$
|
|
^addform'^
|
|
#content
|
|
%pre $string.content$
|
|
|]
|
|
where m = fromMaybe (string "") msg
|
|
navbar' = navbar here a p
|
|
addform' | here == JournalPage = addform
|
|
| otherwise = nulltemplate
|
|
stylesheet = StyleCss
|
|
metacontent = "text/html; charset=utf-8"
|
|
|
|
nulltemplate = [$hamlet||]
|
|
|
|
navbar :: HledgerWebAppRoute -> String -> String -> Hamlet HledgerWebAppRoute
|
|
navbar here a p = [$hamlet|
|
|
#navbar
|
|
%a.toprightlink!href=$string.hledgerurl$ hledger.org
|
|
\ $
|
|
%a.toprightlink!href=$string.manualurl$ manual
|
|
\ $
|
|
^navlinks'^
|
|
^searchform'^
|
|
|]
|
|
where navlinks' = navlinks here a p
|
|
searchform' = searchform here a p
|
|
|
|
navlinks :: HledgerWebAppRoute -> String -> String -> Hamlet HledgerWebAppRoute
|
|
navlinks here a p = [$hamlet|
|
|
#navlinks
|
|
^journallink^ $
|
|
(^editlink^) $
|
|
| ^registerlink^ $
|
|
| ^balancelink^ $
|
|
|]
|
|
where
|
|
journallink = navlink here "journal" JournalPage
|
|
editlink = navlink here "edit" EditPage
|
|
registerlink = navlink here "register" RegisterPage
|
|
balancelink = navlink here "balance" BalancePage
|
|
navlink here s dest = [$hamlet|%a.$style$!href=@?u@ $string.s$|]
|
|
where u = (dest, concat [(if null a then [] else [("a", a)])
|
|
,(if null p then [] else [("p", p)])])
|
|
style | here == dest = string "navlinkcurrent"
|
|
| otherwise = string "navlink"
|
|
|
|
searchform :: HledgerWebAppRoute -> String -> String -> Hamlet HledgerWebAppRoute
|
|
searchform here a p = [$hamlet|
|
|
%form#searchform!method=GET
|
|
filter by: $
|
|
%input!name=a!size=20!value=$string.a$
|
|
^ahelp^ $
|
|
in period: $
|
|
%input!name=p!size=20!value=$string.p$
|
|
^phelp^ $
|
|
%input!type=submit!value=filter
|
|
^resetlink^
|
|
|]
|
|
where
|
|
ahelp = helplink "filter-patterns" "?"
|
|
phelp = helplink "period-expressions" "?"
|
|
resetlink
|
|
| null a && null p = nulltemplate
|
|
| otherwise = [$hamlet|%span#resetlink $
|
|
%a!href=@here@ reset|]
|
|
|
|
helplink topic label = [$hamlet|%a!href=$string.u$ $string.label$|]
|
|
where u = manualurl ++ if null topic then "" else '#':topic
|
|
|
|
addform :: Hamlet HledgerWebAppRoute
|
|
addform = [$hamlet|
|
|
%form!method=POST
|
|
%table.form#addform!cellpadding=0!cellspacing=0!border=0
|
|
%tr.formheading
|
|
%td!colspan=4
|
|
%span#formheading Add a transaction:
|
|
%tr
|
|
%td!colspan=4
|
|
%table!cellpadding=0!cellspacing=0!border=0
|
|
%tr#descriptionrow
|
|
%td
|
|
Date:
|
|
%td
|
|
%input!size=15!name=date!value=$string.date$
|
|
%td
|
|
Description:
|
|
%td
|
|
%input!size=35!name=description!value=$string.desc$
|
|
%tr.helprow
|
|
%td
|
|
%td
|
|
#help $string.datehelp$ ^datehelplink^ $
|
|
%td
|
|
%td
|
|
#help $string.deschelp$
|
|
^transactionfields1^
|
|
^transactionfields2^
|
|
%tr#addbuttonrow
|
|
%td!colspan=4
|
|
%input!type=submit!value=$string.addlabel$
|
|
|]
|
|
where
|
|
datehelplink = helplink "dates" "..."
|
|
datehelp = "eg: 7/20, 2010/1/1, "
|
|
deschelp = "eg: supermarket (optional)"
|
|
addlabel = "add transaction"
|
|
date = "today"
|
|
desc = ""
|
|
transactionfields1 = transactionfields 1
|
|
transactionfields2 = transactionfields 2
|
|
|
|
-- transactionfields :: Int -> Hamlet String
|
|
transactionfields n = [$hamlet|
|
|
%tr#postingrow
|
|
%td!align=right
|
|
$string.label$:
|
|
%td
|
|
%input!size=35!name=$string.acctvar$!value=$string.acct$
|
|
^amtfield^
|
|
%tr.helprow
|
|
%td
|
|
%td
|
|
#help $string.accthelp$
|
|
%td
|
|
%td
|
|
#help $string.amthelp$
|
|
|]
|
|
where
|
|
label | n == 1 = "To account"
|
|
| otherwise = "From account"
|
|
accthelp | n == 1 = "eg: expenses:food"
|
|
| otherwise = "eg: assets:bank:checking"
|
|
amtfield | n == 1 = [$hamlet|
|
|
%td
|
|
Amount:
|
|
%td
|
|
%input!size=15!name=$string.amtvar$!value=$string.amt$
|
|
|]
|
|
| otherwise = nulltemplate
|
|
amthelp | n == 1 = "eg: 5, $6, €7.01"
|
|
| otherwise = ""
|
|
acct = ""
|
|
amt = ""
|
|
numbered = (++ show n)
|
|
acctvar = numbered "accountname"
|
|
amtvar = numbered "amount"
|
|
|
|
postJournalPage :: Handler HledgerWebApp RepPlain
|
|
postJournalPage = do
|
|
today <- liftIO getCurrentDay
|
|
-- get form input values. M means a Maybe value.
|
|
(dateM, descM, acct1M, amt1M, acct2M, amt2M) <- runFormPost'
|
|
$ (,,,,,)
|
|
<$> maybeStringInput "date"
|
|
<*> maybeStringInput "description"
|
|
<*> maybeStringInput "accountname1"
|
|
<*> maybeStringInput "amount1"
|
|
<*> maybeStringInput "accountname2"
|
|
<*> maybeStringInput "amount2"
|
|
-- 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
|
|
descE = Right $ fromMaybe "" descM
|
|
acct1E = maybe (Left "to account required") Right acct1M
|
|
acct2E = maybe (Left "from account required") Right acct2M
|
|
amt1E = maybe (Left "amount required") (either (const $ Left "could not parse amount") Right . parse someamount "") amt1M
|
|
amt2E = maybe (Right missingamt) (either (const $ Left "could not parse amount") Right . parse someamount "") amt2M
|
|
strEs = [dateE, descE, acct1E, acct2E]
|
|
amtEs = [amt1E, amt2E]
|
|
[date,desc,acct1,acct2] = rights strEs
|
|
[amt1,amt2] = rights amtEs
|
|
errs = lefts strEs ++ lefts amtEs
|
|
-- if no errors so far, generate a transaction and balance it or get the error.
|
|
tE | not $ null errs = Left errs
|
|
| otherwise = either (\e -> Left ["unbalanced postings: " ++ (head $ lines e)]) Right
|
|
(balanceTransaction $ nulltransaction {
|
|
tdate=parsedate date
|
|
,teffectivedate=Nothing
|
|
,tstatus=False
|
|
,tcode=""
|
|
,tdescription=desc
|
|
,tcomment=""
|
|
,tpostings=[
|
|
Posting False acct1 amt1 "" RegularPosting Nothing
|
|
,Posting False acct2 amt2 "" RegularPosting Nothing
|
|
]
|
|
,tpreceding_comment_lines=""
|
|
})
|
|
-- display errors or add transaction
|
|
case tE of
|
|
Left errs -> do
|
|
-- save current form values in session
|
|
setMessage $ string $ intercalate "; " errs
|
|
redirect RedirectTemporary JournalPage
|
|
|
|
Right t -> do
|
|
let t' = txnTieKnot t -- XXX move into balanceTransaction
|
|
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
|
liftIO $ journalAddTransaction j t'
|
|
setMessage $ string $ printf "Added transaction:\n%s" (show t')
|
|
redirect RedirectTemporary JournalPage
|
|
|
|
getEditPage :: Handler HledgerWebApp RepHtml
|
|
getEditPage = do
|
|
-- app <- getYesod
|
|
-- t <- liftIO $ getCurrentLocalTime
|
|
a <- fromMaybe "" <$> lookupGetParam "a"
|
|
p <- fromMaybe "" <$> lookupGetParam "p"
|
|
-- opts = appOpts app ++ [Period p]
|
|
-- args = appArgs app ++ [a]
|
|
-- fspec = optsToFilterSpec opts args t
|
|
-- reload journal's text, without parsing, if changed
|
|
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
|
changed <- liftIO $ journalFileIsNewer j
|
|
-- XXX readFile may throw an error
|
|
s <- liftIO $ if changed then readFile (filepath j) else return (jtext j)
|
|
-- render the page
|
|
msg <- getMessage
|
|
Just here <- getCurrentRoute
|
|
hamletToRepHtml $ template' here msg a p "hledger" s
|
|
|
|
template' here msg a p title content = [$hamlet|
|
|
!!!
|
|
%html
|
|
%head
|
|
%title $string.title$
|
|
%meta!http-equiv=Content-Type!content=$string.metacontent$
|
|
%link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
|
|
%body
|
|
^navbar'^
|
|
#messages $m$
|
|
^editform'^
|
|
|]
|
|
where m = fromMaybe (string "") msg
|
|
navbar' = navbar here a p
|
|
stylesheet = StyleCss
|
|
metacontent = "text/html; charset=utf-8"
|
|
editform' = editform content
|
|
|
|
editform :: String -> Hamlet HledgerWebAppRoute
|
|
editform t = [$hamlet|
|
|
%form!method=POST
|
|
%table.form#editform!cellpadding=0!cellspacing=0!border=0
|
|
%tr.formheading
|
|
%td!colspan=2
|
|
%span!style=float:right; ^formhelp^
|
|
%span#formheading Edit journal:
|
|
%tr
|
|
%td!colspan=2
|
|
%textarea!name=text!rows=30!cols=80
|
|
$string.t$
|
|
%tr#addbuttonrow
|
|
%td
|
|
%a!href=@JournalPage@ cancel
|
|
%td!align=right
|
|
%input!type=submit!value=$string.submitlabel$
|
|
%tr.helprow
|
|
%td
|
|
%td!align=right
|
|
#help $string.edithelp$
|
|
|]
|
|
where
|
|
submitlabel = "save journal"
|
|
formhelp = helplink "file-format" "file format help"
|
|
edithelp = "Are you sure ? All previous data will be replaced"
|
|
|
|
postEditPage :: Handler HledgerWebApp RepPlain
|
|
postEditPage = do
|
|
-- get form input values, or basic validation errors. E means an Either value.
|
|
textM <- runFormPost' $ maybeStringInput "text"
|
|
let textE = maybe (Left "No value provided") Right textM
|
|
-- display errors or add transaction
|
|
case textE of
|
|
Left errs -> do
|
|
-- XXX should save current form values in session
|
|
setMessage $ string errs
|
|
redirect RedirectTemporary JournalPage
|
|
|
|
Right t' -> do
|
|
-- try to avoid unnecessary backups or saving invalid data
|
|
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
|
filechanged' <- liftIO $ journalFileIsNewer j
|
|
let f = filepath j
|
|
told = jtext j
|
|
tnew = filter (/= '\r') t'
|
|
changed = tnew /= told || filechanged'
|
|
-- changed <- liftIO $ writeFileWithBackupIfChanged f t''
|
|
if not changed
|
|
then do
|
|
setMessage $ string $ "No change"
|
|
redirect RedirectTemporary EditPage
|
|
else do
|
|
jE <- liftIO $ journalFromPathAndString Nothing f tnew
|
|
either
|
|
(\e -> do
|
|
setMessage $ string e
|
|
redirect RedirectTemporary EditPage)
|
|
(const $ do
|
|
liftIO $ writeFileWithBackup f tnew
|
|
setMessage $ string $ printf "Saved journal %s\n" (show f)
|
|
redirect RedirectTemporary JournalPage)
|
|
jE
|
|
|