{-# 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 ((), takeFileName) 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.Cli.Version (version) 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" data HledgerWebApp = HledgerWebApp { appRoot :: String ,appWebdir :: FilePath ,appOpts :: [Opt] ,appArgs :: [String] ,appJournal :: Journal } mkYesod "HledgerWebApp" [$parseRoutes| / IndexPage GET /style.css StyleCss GET /journalonly JournalOnlyPage GET POST /registeronly RegisterOnlyPage GET /accounts AccountsPage GET /journal AccountsJournalPage GET POST /register AccountsRegisterPage GET POST |] instance Yesod HledgerWebApp where approot = appRoot defaultpage = AccountsJournalPage -- | A bundle of useful data passed to templates. data TemplateData = TD { here :: HledgerWebAppRoute -- ^ the current page's route ,title :: String -- ^ page's title ,msg :: Maybe (Html ()) -- ^ transient message ,a :: String -- ^ a (acct/desc filter pattern) parameter ,p :: String -- ^ p (period expression) parameter ,j :: Journal -- ^ the current journal } mktd = TD { here = IndexPage ,title = "hledger" ,msg = Nothing ,a = "" ,p = "" ,j = nulljournal } -- | The web command. 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{ appRoot=baseurl ,appWebdir=fp ,appOpts=opts ,appArgs=args ,appJournal=j } withStore "hledger" $ do putValue "hledger" "journal" j basicHandler' port Nothing app -- | Gather all the stuff we want for a typical hledger web request handler. getHandlerParameters :: Handler HledgerWebApp (String, String, [Opt], FilterSpec, Journal, Maybe (Html ()), HledgerWebAppRoute) getHandlerParameters = do Just here <- getCurrentRoute (a, p, opts, fspec) <- getReportParameters (j, err) <- getLatestJournal opts msg <- getMessage' err return (a, p, opts, fspec, j, msg, here) where -- | Get current report parameters for this request. getReportParameters :: Handler HledgerWebApp (String, String, [Opt], FilterSpec) getReportParameters = 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 return (a, p, opts, fspec) -- | 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 -- ui message. getLatestJournal :: [Opt] -> Handler HledgerWebApp (Journal, Maybe String) getLatestJournal opts = do j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" (jE, changed) <- liftIO $ journalReloadIfChanged opts j if not changed then return (j,Nothing) else case jE of Right j' -> do liftIO $ putValue "hledger" "journal" j' return (j',Nothing) Left e -> do setMessage $ string "error while reading" {- ++ ": " ++ e-} return (j, Just e) -- | Helper to work around a yesod feature (can't set and get a message in the same request.) getMessage' :: Maybe String -> Handler HledgerWebApp (Maybe (Html ())) getMessage' newmsgstr = do oldmsg <- getMessage return $ maybe oldmsg (Just . string) newmsgstr ---------------------------------------------------------------------- -- handlers & templates getStyleCss :: Handler HledgerWebApp () getStyleCss = do app <- getYesod let dir = appWebdir app sendFile "text/css" $ dir "style.css" ---------------------------------------------------------------------- getIndexPage :: Handler HledgerWebApp () getIndexPage = redirect RedirectTemporary defaultpage ---------------------------------------------------------------------- -- | A combined accounts and journal view. getAccountsJournalPage :: Handler HledgerWebApp RepHtml getAccountsJournalPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters -- app <- getYesod -- t <- liftIO $ getCurrentLocalTime let -- args = appArgs app -- fspec' = optsToFilterSpec opts args t br = balanceReportAsHtml opts td $ balanceReport opts fspec j jr = journalReportAsHtml opts td $ journalReport opts fspec j td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} editform' = editform td $ jtext j hamletToRepHtml $ pageLayout td [$hamlet| ^scripts^ %div.ledger %div.accounts!style=float:left; ^br^ ^navlinks.td^ ^addform^ ^editform'^ %div#transactions.journal ^filterform.td^ ^jr^ |] postAccountsJournalPage :: Handler HledgerWebApp RepPlain postAccountsJournalPage = postJournalOnlyPage ---------------------------------------------------------------------- -- | A combined accounts and register view. getAccountsRegisterPage :: Handler HledgerWebApp RepHtml getAccountsRegisterPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters -- app <- getYesod -- t <- liftIO $ getCurrentLocalTime let -- args = appArgs app -- opts' = Empty:opts -- fspec' = optsToFilterSpec opts' args t br = balanceReportAsHtml opts td $ balanceReport opts fspec j rr = registerReportAsHtml opts td $ registerReport opts fspec j td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} editform' = editform td $ jtext j hamletToRepHtml $ pageLayout td [$hamlet| ^scripts^ %div.ledger %div.accounts!style=float:left; ^br^ ^navlinks.td^ ^addform^ ^editform'^ %div#transactions.register ^filterform.td^ ^rr^ |] postAccountsRegisterPage :: Handler HledgerWebApp RepPlain postAccountsRegisterPage = postJournalOnlyPage ---------------------------------------------------------------------- -- | A simple accounts and balances view like hledger balance. getAccountsPage :: Handler HledgerWebApp RepHtml getAccountsPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} hamletToRepHtml $ pageLayout td $ balanceReportAsHtml opts td $ balanceReport opts fspec j -- | Render a balance report as HTML. balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Hamlet HledgerWebAppRoute balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet| %table.balancereport ^allaccts^ $forall items i ^itemAsHtml' i^ %tr.totalrule %td!colspan=2 %tr %td %td!align=right $mixedAmountAsHtml.total$ |] where filtering = not $ null a && null p showmore = if filtering then [$hamlet| ^showmore'^ \ | $ %a!href=@here@ show all |] else nulltemplate showmore' = case (filtering, items) of -- cunning parent account logic (True, ((acct, _, _, _):_)) -> let a' = if isAccountRegex a then a else acct a'' = accountNameToAccountRegex $ parentAccountName $ accountRegexToAccountName a' parenturl = (here, [("a",a''), ("p",p)]) in [$hamlet| \ | $ %a!href=@?parenturl@ show more ↑ |] _ -> nulltemplate allacctslink = True allaccts = if allacctslink then -- [$hamlet|%tr.$current$ -- %td -- %a!href=@?u@ all accounts -- %td [$hamlet| accounts \ $ %span#showmoreaccounts ^showmore^

|] else nulltemplate -- where u = (here, [("a",".*"),("p",p)]) -- current = "" -- if a == ".*" then "current" else "" itemAsHtml' = itemAsHtml td itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet HledgerWebAppRoute itemAsHtml TD{p=p} (acct, adisplay, adepth, abal) = [$hamlet| %tr.item.$current$ %td.account $indent$ %a!href=$aurl$ $adisplay$ %td.balance!align=right $mixedAmountAsHtml.abal$ |] where current = "" -- if not (null a) && containsRegex a acct then "current" else "" indent = preEscapedString $ concat $ replicate (2 * (adepth + if allacctslink then 1 else 0)) " " aurl = printf ".?a=%s%s" (accountNameToAccountRegex acct) p' :: String p' = if null p then "" else printf "&p=%s" p accountNameToAccountRegex :: String -> String accountNameToAccountRegex "" = "" accountNameToAccountRegex a = printf "^%s(:|$)" a accountRegexToAccountName :: String -> String accountRegexToAccountName = gsubRegexPR "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" isAccountRegex :: String -> Bool isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:(" ---------------------------------------------------------------------- -- | A basic journal view, like hledger print, with editing. getJournalOnlyPage :: Handler HledgerWebApp RepHtml getJournalOnlyPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} editform' = editform td $ jtext j txns = journalReportAsHtml opts td $ journalReport opts fspec j hamletToRepHtml $ pageLayout td [$hamlet| %div.journal ^scripts^ %div.nav2 %a#addformlink!href!onclick="return addformToggle()" add one transaction \ | $ %a#editformlink!href!onclick="return editformToggle()" edit the whole journal ^addform^ ^editform'^ #transactions ^txns^ |] -- | Render a journal report as HTML. journalReportAsHtml :: [Opt] -> TemplateData -> JournalReport -> Hamlet HledgerWebAppRoute journalReportAsHtml _ td items = [$hamlet| %table.journalreport $forall number.items i ^itemAsHtml' i^ |] where number = zip [1..] itemAsHtml' = itemAsHtml td itemAsHtml :: TemplateData -> (Int, JournalReportItem) -> Hamlet HledgerWebAppRoute itemAsHtml _ (n, t) = [$hamlet| %tr.item.$evenodd$ %td.transaction %pre $txn$ |] where evenodd = if even n then "even" else "odd" txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse addform :: Hamlet HledgerWebAppRoute addform = [$hamlet| %form#addform!method=POST!style=display:none; %table.form %tr %td!colspan=4 %table %tr#descriptionrow %td Date: %td %input.textinput!size=15!name=date!value=$date$ %td!style=padding-left:1em; Description: %td %input.textinput!size=35!name=description!value=$desc$ %tr.helprow %td %td .help $datehelp$ $ %td %td .help $deschelp$ ^transactionfields1^ ^transactionfields2^ %tr#addbuttonrow %td!colspan=4 %input!type=hidden!name=add!value=1 %input!type=submit!name=submit!value="add transaction" |] where -- datehelplink = helplink "dates" "..." datehelp = "eg: 7/20, 2010/1/1, " deschelp = "eg: supermarket (optional)" date = "today" desc = "" transactionfields1 = transactionfields 1 transactionfields2 = transactionfields 2 transactionfields :: Int -> Hamlet HledgerWebAppRoute transactionfields n = [$hamlet| %tr#postingrow %td!align=right $label$: %td %input.textinput!size=35!name=$acctvar$!value=$acct$ ^amtfield^ %tr.helprow %td %td .help $accthelp$ %td %td .help $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!style=padding-left:1em; Amount: %td %input.textinput!size=15!name=$amtvar$!value=$amt$ |] | otherwise = nulltemplate amthelp | n == 1 = "eg: 5, $6, €7.01" | otherwise = "" acct = "" amt = "" numbered = (++ show n) acctvar = numbered "accountname" amtvar = numbered "amount" editform :: TemplateData -> String -> Hamlet HledgerWebAppRoute editform _ content = [$hamlet| %form#editform!method=POST!style=display:none; %table.form#editform %tr %td!colspan=2 %textarea!name=text!rows=30!cols=80 $content$ %tr#addbuttonrow %td %span.help ^formathelp^ %td!align=right %span.help Are you sure ? This will overwrite the journal. $ %input!type=hidden!name=edit!value=1 %input!type=submit!name=submit!value="save journal" \ or $ %a!href!onclick="return editformToggle()" cancel |] where formathelp = helplink "file-format" "file format help" scripts = [$hamlet| |] postJournalOnlyPage :: Handler HledgerWebApp RepPlain postJournalOnlyPage = do edit <- runFormPost' $ maybeStringInput "edit" if isJust edit then postEditForm else postAddForm -- | Handle a journal add form post. postAddForm :: Handler HledgerWebApp RepPlain postAddForm = do (_, _, opts, _, _, _, _) <- getHandlerParameters 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 AccountsRegisterPage Right t -> do let t' = txnTieKnot t -- XXX move into balanceTransaction j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" liftIO $ journalAddTransaction j opts t' setMessage $ string $ printf "Added transaction:\n%s" (show t') redirect RedirectTemporary AccountsRegisterPage -- | Handle a journal edit form post. postEditForm :: Handler HledgerWebApp RepPlain postEditForm = 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 AccountsJournalPage 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 AccountsJournalPage else do jE <- liftIO $ journalFromPathAndString Nothing f tnew either (\e -> do setMessage $ string e redirect RedirectTemporary AccountsJournalPage) (const $ do liftIO $ writeFileWithBackup f tnew setMessage $ string $ printf "Saved journal %s\n" (show f) redirect RedirectTemporary AccountsJournalPage) jE ---------------------------------------------------------------------- -- | A simple postings view like hledger register. getRegisterOnlyPage :: Handler HledgerWebApp RepHtml getRegisterOnlyPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} hamletToRepHtml $ pageLayout td $ registerReportAsHtml opts td $ registerReport opts fspec j -- | Render a register report as HTML. registerReportAsHtml :: [Opt] -> TemplateData -> RegisterReport -> Hamlet HledgerWebAppRoute registerReportAsHtml _ td items = [$hamlet| %table.registerreport $forall number.items i ^itemAsHtml' i^ |] where number = zip [1..] itemAsHtml' = itemAsHtml td itemAsHtml :: TemplateData -> (Int, RegisterReportItem) -> Hamlet HledgerWebAppRoute itemAsHtml TD{p=p} (n, (ds, posting, b)) = [$hamlet| %tr.item.$evenodd$.$firstposting$ %td.date $date$ %td.description $desc$ %td.account %a!href=$aurl$ $acct$ %td.amount!align=right $mixedAmountAsHtml.pamount.posting$ %td.balance!align=right $mixedAmountAsHtml.b$ |] where evenodd = if even n then "even" else "odd" (firstposting, date, desc) = case ds of Just (da, de) -> ("firstposting", show da, de) Nothing -> ("", "", "") acct = paccount posting aurl = printf ".?a=%s%s" (accountNameToAccountRegex acct) p' :: String p' = if null p then "" else printf "&p=%s" p mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "
" $ lines $ show b where addclass = printf "%s" c c = case isNegativeMixedAmount b of Just True -> "negative amount" _ -> "positive amount" ---------------------------------------------------------------------- -- | A standalone journal edit form page. getEditPage :: Handler HledgerWebApp RepHtml getEditPage = do (a, p, _, _, _, msg, here) <- getHandlerParameters -- reload journal's text without parsing, if changed -- XXX are we doing this right ? j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" changed <- liftIO $ journalFileIsNewer j s <- liftIO $ if changed then readFile (filepath j) else return (jtext j) -- XXX readFile may throw an error let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} hamletToRepHtml $ pageLayout td $ editform td s ---------------------------------------------------------------------- -- | Wrap a template with the standard hledger web ui page layout. pageLayout :: TemplateData -> Hamlet HledgerWebAppRoute -> Hamlet HledgerWebAppRoute pageLayout td@TD{title=title, msg=msg} content = [$hamlet| !!! %html %head %title $title$ %meta!http-equiv=Content-Type!content=$metacontent$ %link!rel=stylesheet!type=text/css!href=@StyleCss@!media=all %body ^navbar.td^ #messages $m$ #content ^content^ |] where m = fromMaybe (string "") msg metacontent = "text/html; charset=utf-8" navbar :: TemplateData -> Hamlet HledgerWebAppRoute navbar TD{j=j} = [$hamlet| #navbar %a.topleftlink!href=$hledgerurl$ hledger
$version$ %a.toprightlink!href=$manualurl$!target=hledgerhelp manual %h1 $journaltitle$ |] where journaltitle = printf "%s" (takeFileName $ filepath j) :: String navlinks :: TemplateData -> Hamlet HledgerWebAppRoute navlinks td = [$hamlet| #navlinks ^accountsjournallink^ \ | $ ^accountsregisterlink^ \ | $ %a#addformlink!href!onclick="return addformToggle()" add transaction \ | $ %a#editformlink!href!onclick="return editformToggle()" edit journal |] where accountsjournallink = navlink td "journal" AccountsJournalPage accountsregisterlink = navlink td "register" AccountsRegisterPage navlink :: TemplateData -> String -> HledgerWebAppRoute -> Hamlet HledgerWebAppRoute navlink TD{here=here,a=a,p=p} s dest = [$hamlet|%a#$s$link.$style$!href=@?u@ $s$|] where u = (dest, concat [(if null a then [] else [("a", a)]) ,(if null p then [] else [("p", p)])]) style | dest == here = "navlinkcurrent" | otherwise = "navlink" filterform :: TemplateData -> Hamlet HledgerWebAppRoute filterform TD{here=here,a=a,p=p} = [$hamlet| #filterformdiv %form#filterform.form!method=GET!style=display:$visible$; %span.$filtering$ filter by account/description: \ $ %input!name=a!size=50!value=$a$ ^ahelp^ \ $ in period: \ $ %input!name=p!size=25!value=$p$ ^phelp^ \ $ %input!type=submit!value=filter $ \ $ ^stopfiltering^ |] where ahelp = helplink "filter-patterns" "?" phelp = helplink "period-expressions" "?" (filtering, visible, _, stopfiltering) | null a && null p = ("", defaultdisplay, [$hamlet|%a#filterformlink!href!onclick="return filterformToggle()" filter...|], nulltemplate) -- [$hamlet|filter by $|]) | otherwise = ("filtering", defaultdisplay, [$hamlet|filtering...|], [$hamlet|%a#stopfilterlink!href=@here@ stop filtering|]) defaultdisplay = "block" helplink :: String -> String -> Hamlet HledgerWebAppRoute helplink topic label = [$hamlet|%a!href=$u$!target=hledgerhelp $label$|] where u = manualurl ++ if null topic then "" else '#':topic nulltemplate = [$hamlet||]