mirror of
https://github.com/simonmichael/hledger.git
synced 2024-11-10 05:39:31 +03:00
rename -fweb to -fweb610 and -fwebyesod to -fweb, misc cabal and docs cleanups
This commit is contained in:
Simon Michael
parent
a52c467941
commit
2f2e500eae
@ -15,16 +15,16 @@ module Hledger.Cli.Commands.All (
|
|||||||
module Hledger.Cli.Commands.Print,
|
module Hledger.Cli.Commands.Print,
|
||||||
module Hledger.Cli.Commands.Register,
|
module Hledger.Cli.Commands.Register,
|
||||||
module Hledger.Cli.Commands.Stats,
|
module Hledger.Cli.Commands.Stats,
|
||||||
|
#ifdef CHART
|
||||||
|
module Hledger.Cli.Commands.Chart,
|
||||||
|
#endif
|
||||||
#ifdef VTY
|
#ifdef VTY
|
||||||
module Hledger.Cli.Commands.Vty,
|
module Hledger.Cli.Commands.Vty,
|
||||||
#endif
|
#endif
|
||||||
#if defined(WEB)
|
#if defined(WEB)
|
||||||
module Hledger.Cli.Commands.Web,
|
module Hledger.Cli.Commands.Web,
|
||||||
#elif defined(WEBYESOD)
|
#elif defined(WEB610)
|
||||||
module Hledger.Cli.Commands.WebYesod,
|
module Hledger.Cli.Commands.Web610,
|
||||||
#endif
|
|
||||||
#ifdef CHART
|
|
||||||
module Hledger.Cli.Commands.Chart,
|
|
||||||
#endif
|
#endif
|
||||||
tests_Hledger_Commands
|
tests_Hledger_Commands
|
||||||
)
|
)
|
||||||
@ -36,16 +36,16 @@ import Hledger.Cli.Commands.Histogram
|
|||||||
import Hledger.Cli.Commands.Print
|
import Hledger.Cli.Commands.Print
|
||||||
import Hledger.Cli.Commands.Register
|
import Hledger.Cli.Commands.Register
|
||||||
import Hledger.Cli.Commands.Stats
|
import Hledger.Cli.Commands.Stats
|
||||||
|
#ifdef CHART
|
||||||
|
import Hledger.Cli.Commands.Chart
|
||||||
|
#endif
|
||||||
#ifdef VTY
|
#ifdef VTY
|
||||||
import Hledger.Cli.Commands.Vty
|
import Hledger.Cli.Commands.Vty
|
||||||
#endif
|
#endif
|
||||||
#if defined(WEB)
|
#if defined(WEB)
|
||||||
import Hledger.Cli.Commands.Web
|
import Hledger.Cli.Commands.Web
|
||||||
#elif defined(WEBYESOD)
|
#elif defined(WEB610)
|
||||||
import Hledger.Cli.Commands.WebYesod
|
import Hledger.Cli.Commands.Web610
|
||||||
#endif
|
|
||||||
#ifdef CHART
|
|
||||||
import Hledger.Cli.Commands.Chart
|
|
||||||
#endif
|
#endif
|
||||||
import Test.HUnit (Test(TestList))
|
import Test.HUnit (Test(TestList))
|
||||||
|
|
||||||
@ -60,14 +60,14 @@ tests_Hledger_Commands = TestList
|
|||||||
,Hledger.Cli.Commands.Register.tests_Register
|
,Hledger.Cli.Commands.Register.tests_Register
|
||||||
-- ,Hledger.Cli.Commands.Stats.tests_Stats
|
-- ,Hledger.Cli.Commands.Stats.tests_Stats
|
||||||
]
|
]
|
||||||
|
-- #ifdef CHART
|
||||||
|
-- ,Hledger.Cli.Commands.Chart.tests_Chart
|
||||||
|
-- #endif
|
||||||
-- #ifdef VTY
|
-- #ifdef VTY
|
||||||
-- ,Hledger.Cli.Commands.Vty.tests_Vty
|
-- ,Hledger.Cli.Commands.Vty.tests_Vty
|
||||||
-- #endif
|
-- #endif
|
||||||
-- #if defined(WEB)
|
-- #if defined(WEB)
|
||||||
-- ,Hledger.Cli.Commands.Web.tests_Web
|
-- ,Hledger.Cli.Commands.Web.tests_Web
|
||||||
-- #elif defined(WEBYESOD)
|
-- #elif defined(WEB610)
|
||||||
-- ,Hledger.Cli.Commands.WebYesod.tests_Web
|
-- ,Hledger.Cli.Commands.Web610.tests_Web
|
||||||
-- #endif
|
|
||||||
-- #ifdef CHART
|
|
||||||
-- ,Hledger.Cli.Commands.Chart.tests_Chart
|
|
||||||
-- #endif
|
-- #endif
|
||||||
|
|||||||
@ -1,313 +1,299 @@
|
|||||||
{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
|
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-}
|
||||||
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
|
|
||||||
{-|
|
{-|
|
||||||
A web-based UI.
|
A web-based UI.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Hledger.Cli.Commands.Web
|
module Hledger.Cli.Commands.Web
|
||||||
where
|
where
|
||||||
import Codec.Binary.UTF8.String (decodeString)
|
import Control.Concurrent -- (forkIO)
|
||||||
import Control.Applicative.Error (Failing(Success,Failure))
|
import Data.Either
|
||||||
import Control.Concurrent
|
import Network.Wai.Handler.SimpleServer (run)
|
||||||
import Control.Monad.Reader (ask)
|
import System.FilePath ((</>))
|
||||||
import Data.IORef (newIORef, atomicModifyIORef)
|
|
||||||
import System.IO.Storage (withStore, putValue, getValue)
|
import System.IO.Storage (withStore, putValue, getValue)
|
||||||
|
import Text.Hamlet
|
||||||
import Text.ParserCombinators.Parsec (parse)
|
import Text.ParserCombinators.Parsec (parse)
|
||||||
|
import Yesod
|
||||||
import Hack.Contrib.Constants (_TextHtmlUTF8)
|
|
||||||
import Hack.Contrib.Response (set_content_type)
|
|
||||||
import qualified Hack (Env, http)
|
|
||||||
import qualified Hack.Contrib.Request (inputs, params, path)
|
|
||||||
import qualified Hack.Contrib.Response (redirect)
|
|
||||||
import Hack.Handler.SimpleServer (run)
|
|
||||||
|
|
||||||
import Network.Loli (loli, io, get, post, html, text, public)
|
|
||||||
import Network.Loli.Type (AppUnit)
|
|
||||||
import Network.Loli.Utils (update)
|
|
||||||
|
|
||||||
import HSP hiding (Request,catch)
|
|
||||||
import qualified HSP (Request(..))
|
|
||||||
|
|
||||||
import Hledger.Cli.Commands.Add (journalAddTransaction)
|
import Hledger.Cli.Commands.Add (journalAddTransaction)
|
||||||
import Hledger.Cli.Commands.Balance
|
import Hledger.Cli.Commands.Balance
|
||||||
import Hledger.Cli.Commands.Histogram
|
|
||||||
import Hledger.Cli.Commands.Print
|
import Hledger.Cli.Commands.Print
|
||||||
import Hledger.Cli.Commands.Register
|
import Hledger.Cli.Commands.Register
|
||||||
|
import Hledger.Cli.Options hiding (value)
|
||||||
|
import Hledger.Cli.Utils
|
||||||
import Hledger.Data
|
import Hledger.Data
|
||||||
import Hledger.Read.Journal (someamount)
|
import Hledger.Read.Journal (someamount)
|
||||||
import Hledger.Cli.Options hiding (value)
|
|
||||||
#ifdef MAKE
|
#ifdef MAKE
|
||||||
import Paths_hledger_make (getDataFileName)
|
import Paths_hledger_make (getDataFileName)
|
||||||
#else
|
#else
|
||||||
import Paths_hledger (getDataFileName)
|
import Paths_hledger (getDataFileName)
|
||||||
#endif
|
#endif
|
||||||
import Hledger.Cli.Utils
|
|
||||||
|
|
||||||
|
|
||||||
tcpport = 5000 :: Int
|
defhost = "localhost"
|
||||||
homeurl = printf "http://localhost:%d/" tcpport
|
defport = 5000
|
||||||
browserdelay = 100000 -- microseconds
|
browserstartdelay = 100000 -- microseconds
|
||||||
|
hledgerurl = "http://hledger.org"
|
||||||
|
manualurl = hledgerurl++"/MANUAL.html"
|
||||||
|
|
||||||
web :: [Opt] -> [String] -> Journal -> IO ()
|
web :: [Opt] -> [String] -> Journal -> IO ()
|
||||||
web opts args j = do
|
web opts args j = do
|
||||||
unless (Debug `elem` opts) $ forkIO browser >> return ()
|
let host = fromMaybe defhost $ hostFromOpts opts
|
||||||
server opts args j
|
port = fromMaybe defport $ portFromOpts opts
|
||||||
|
url = printf "http://%s:%d" host port :: String
|
||||||
|
unless (Debug `elem` opts) $ forkIO (browser url) >> return ()
|
||||||
|
server url port opts args j
|
||||||
|
|
||||||
browser :: IO ()
|
browser :: String -> IO ()
|
||||||
browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
|
browser url = putStrLn "starting web browser" >> threadDelay browserstartdelay >> openBrowserOn url >> return ()
|
||||||
|
|
||||||
server :: [Opt] -> [String] -> Journal -> IO ()
|
server :: String -> Int -> [Opt] -> [String] -> Journal -> IO ()
|
||||||
server opts args j =
|
server url port opts args j = do
|
||||||
-- server initialisation
|
printf "starting web server at %s\n" url
|
||||||
withStore "hledger" $ do -- IO ()
|
fp <- getDataFileName "web"
|
||||||
printf "starting web server on port %d\n" tcpport
|
let app = HledgerWebApp{
|
||||||
t <- getCurrentLocalTime
|
appOpts=opts
|
||||||
webfiles <- getDataFileName "web"
|
,appArgs=args
|
||||||
putValue "hledger" "journal" j
|
,appJournal=j
|
||||||
run tcpport $ -- (Env -> IO Response) -> IO ()
|
,appWebdir=fp
|
||||||
\env -> do -- IO Response
|
,appRoot=url
|
||||||
-- general request handler
|
}
|
||||||
let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
|
withStore "hledger" $ do -- IO ()
|
||||||
args' = args ++ map decodeString (reqParamUtf8 env "a")
|
putValue "hledger" "journal" j
|
||||||
j' <- fromJust `fmap` getValue "hledger" "journal"
|
toWaiApp app >>= run port
|
||||||
(changed, j'') <- io $ journalReloadIfChanged opts j'
|
|
||||||
when changed $ putValue "hledger" "journal" j''
|
|
||||||
-- declare path-specific request handlers
|
|
||||||
let command :: [String] -> ([Opt] -> FilterSpec -> Journal -> String) -> AppUnit
|
|
||||||
command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) j''
|
|
||||||
(loli $ -- State Loli () -> (Env -> IO Response)
|
|
||||||
do
|
|
||||||
get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
|
|
||||||
get "/register" $ command [] showRegisterReport
|
|
||||||
get "/histogram" $ command [] showHistogram
|
|
||||||
get "/transactions" $ ledgerpage [] j'' (showTransactions (optsToFilterSpec opts' args' t))
|
|
||||||
post "/transactions" $ handleAddform j''
|
|
||||||
get "/env" $ getenv >>= (text . show)
|
|
||||||
get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
|
|
||||||
get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
|
|
||||||
public (Just webfiles) ["/style.css"]
|
|
||||||
get "/" $ redirect ("transactions") Nothing
|
|
||||||
) env
|
|
||||||
|
|
||||||
getenv = ask
|
data HledgerWebApp = HledgerWebApp {
|
||||||
response = update
|
appOpts::[Opt]
|
||||||
redirect u c = response $ Hack.Contrib.Response.redirect u c
|
,appArgs::[String]
|
||||||
|
,appJournal::Journal
|
||||||
|
,appWebdir::FilePath
|
||||||
|
,appRoot::String
|
||||||
|
}
|
||||||
|
|
||||||
reqParamUtf8 :: Hack.Env -> String -> [String]
|
instance Yesod HledgerWebApp where approot = appRoot
|
||||||
reqParamUtf8 env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
|
|
||||||
|
|
||||||
ledgerpage :: [String] -> Journal -> (Journal -> String) -> AppUnit
|
mkYesod "HledgerWebApp" [$parseRoutes|
|
||||||
ledgerpage msgs j f = do
|
/ IndexPage GET
|
||||||
env <- getenv
|
/transactions TransactionsPage GET POST
|
||||||
(_, j') <- io $ journalReloadIfChanged [] j
|
/register RegisterPage GET
|
||||||
hsp msgs $ const <div><% addform env %><pre><% f j' %></pre></div>
|
/balance BalancePage GET
|
||||||
|
/style.css StyleCss GET
|
||||||
|
/params ParamsDebug GET
|
||||||
|
|]
|
||||||
|
|
||||||
-- | A loli directive to serve a string in pre tags within the hledger web
|
getParamsDebug = do
|
||||||
-- layout.
|
r <- getRequest
|
||||||
string :: [String] -> String -> AppUnit
|
return $ RepHtml $ toContent $ show $ reqGetParams r
|
||||||
string msgs s = hsp msgs $ const <pre><% s %></pre>
|
|
||||||
|
|
||||||
-- | A loli directive to serve a hsp template wrapped in the hledger web
|
getIndexPage :: Handler HledgerWebApp ()
|
||||||
-- layout. The hack environment is passed in to every hsp template as an
|
getIndexPage = redirect RedirectTemporary TransactionsPage
|
||||||
-- argument, since I don't see how to get it within the hsp monad.
|
|
||||||
-- A list of messages is also passed, eg for form errors.
|
|
||||||
hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
|
|
||||||
hsp msgs f = do
|
|
||||||
env <- getenv
|
|
||||||
let contenthsp = f env
|
|
||||||
pagehsp = hledgerpage env msgs title contenthsp
|
|
||||||
html =<< (io $ do
|
|
||||||
hspenv <- hackEnvToHspEnv env
|
|
||||||
(_,xml) <- runHSP html4Strict pagehsp hspenv
|
|
||||||
return $ addDoctype $ renderAsHTML xml)
|
|
||||||
response $ set_content_type _TextHtmlUTF8
|
|
||||||
where
|
|
||||||
title = ""
|
|
||||||
addDoctype = ("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n" ++)
|
|
||||||
hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
|
|
||||||
hackEnvToHspEnv env = do
|
|
||||||
x <- newIORef 0
|
|
||||||
let req = HSP.Request (reqParamUtf8 env) (Hack.http env)
|
|
||||||
num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
|
|
||||||
return $ HSPEnv req num
|
|
||||||
|
|
||||||
-- htmlToHsp :: Html -> HSP XML
|
getStyleCss :: Handler HledgerWebApp RepPlain
|
||||||
-- htmlToHsp h = return $ cdata $ showHtml h
|
getStyleCss = do
|
||||||
|
app <- getYesod
|
||||||
|
let dir = appWebdir app
|
||||||
|
s <- liftIO $ readFile $ dir </> "style.css"
|
||||||
|
header "Content-Type" "text/css"
|
||||||
|
return $ RepPlain $ toContent s
|
||||||
|
|
||||||
-- views
|
getTransactionsPage :: Handler HledgerWebApp RepHtml
|
||||||
|
getTransactionsPage = withLatestJournalRender (const showTransactions)
|
||||||
|
|
||||||
hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
|
getRegisterPage :: Handler HledgerWebApp RepHtml
|
||||||
hledgerpage env msgs title content =
|
getRegisterPage = withLatestJournalRender showRegisterReport
|
||||||
<html>
|
|
||||||
<head>
|
|
||||||
<meta http-equiv = "Content-Type" content = "text/html; charset=utf-8" />
|
|
||||||
<link rel="stylesheet" type="text/css" href="/style.css" media="all" />
|
|
||||||
<title><% title %></title>
|
|
||||||
</head>
|
|
||||||
<body>
|
|
||||||
<% navbar env %>
|
|
||||||
<div id="messages"><% intercalate ", " msgs %></div>
|
|
||||||
<div id="content"><% content %></div>
|
|
||||||
</body>
|
|
||||||
</html>
|
|
||||||
|
|
||||||
navbar :: Hack.Env -> HSP XML
|
getBalancePage :: Handler HledgerWebApp RepHtml
|
||||||
navbar env =
|
getBalancePage = withLatestJournalRender showBalanceReport
|
||||||
<div id="navbar">
|
|
||||||
<a href="http://hledger.org" id="hledgerorglink">hledger.org</a>
|
|
||||||
<% navlinks env %>
|
|
||||||
<% searchform env %>
|
|
||||||
<a href="http://hledger.org/MANUAL.html" id="helplink">help</a>
|
|
||||||
</div>
|
|
||||||
|
|
||||||
getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p
|
withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
|
||||||
|
withLatestJournalRender reportfn = do
|
||||||
|
app <- getYesod
|
||||||
|
params <- getParams
|
||||||
|
t <- liftIO $ getCurrentLocalTime
|
||||||
|
let head' x = if null x then "" else head x
|
||||||
|
as = head' $ params "a"
|
||||||
|
ps = head' $ params "p"
|
||||||
|
opts = appOpts app ++ [Period ps]
|
||||||
|
args = appArgs app ++ [as]
|
||||||
|
fspec = optsToFilterSpec opts args t
|
||||||
|
-- reload journal if changed
|
||||||
|
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||||
|
(changed, j') <- liftIO $ journalReloadIfChanged opts j
|
||||||
|
when changed $ liftIO $ putValue "hledger" "journal" j'
|
||||||
|
-- run the specified report using this request's params
|
||||||
|
let s = reportfn opts fspec j'
|
||||||
|
-- render the standard template
|
||||||
|
req <- getRequest
|
||||||
|
msg <- getMessage
|
||||||
|
Just here <- getRoute
|
||||||
|
hamletToRepHtml $ template here req msg as ps "hledger" s
|
||||||
|
|
||||||
navlinks :: Hack.Env -> HSP XML
|
template :: HledgerWebAppRoutes
|
||||||
navlinks _ = do
|
-> Request -> Maybe (Html ()) -> String -> String
|
||||||
a <- getParamOrNull "a"
|
-> String -> String -> Hamlet HledgerWebAppRoutes
|
||||||
p <- getParamOrNull "p"
|
template here req msg as ps title content = [$hamlet|
|
||||||
let addparams=(++(printf "?a=%s&p=%s" a p))
|
!!!
|
||||||
link s = <a href=(addparams s) class="navlink"><% s %></a>
|
%html
|
||||||
<div id="navlinks">
|
%head
|
||||||
<% link "transactions" %> |
|
%title $string.title$
|
||||||
<% link "register" %> |
|
%meta!http-equiv=Content-Type!content=$string.metacontent$
|
||||||
<% link "balance" %>
|
%link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
|
||||||
</div>
|
%body
|
||||||
|
^navbar'^
|
||||||
|
#messages $m$
|
||||||
|
^addform'^
|
||||||
|
#content
|
||||||
|
%pre $string.content$
|
||||||
|
|]
|
||||||
|
where m = fromMaybe (string "") msg
|
||||||
|
navbar' = navbar here req as ps
|
||||||
|
addform' = addform req as ps
|
||||||
|
stylesheet = StyleCss
|
||||||
|
metacontent = "text/html; charset=utf-8"
|
||||||
|
|
||||||
searchform :: Hack.Env -> HSP XML
|
navbar :: HledgerWebAppRoutes -> Request -> String -> String -> Hamlet HledgerWebAppRoutes
|
||||||
searchform env = do
|
navbar here req as ps = [$hamlet|
|
||||||
a <- getParamOrNull "a"
|
#navbar
|
||||||
p <- getParamOrNull "p"
|
%a#hledgerorglink!href=$string.hledgerurl$ hledger.org
|
||||||
let resetlink | null a && null p = <span></span>
|
^navlinks'^
|
||||||
| otherwise = <span id="resetlink"><% nbsp %><a href=u>reset</a></span>
|
^searchform'^
|
||||||
where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
|
%a#helplink!href=$string.manualurl$ help
|
||||||
<form action="" id="searchform">
|
|]
|
||||||
<% nbsp %>search for:<% nbsp %><input name="a" size="20" value=a
|
where navlinks' = navlinks req as ps
|
||||||
/><% help "filter-patterns"
|
searchform' = searchform here as ps
|
||||||
%><% nbsp %><% nbsp %>in reporting period:<% nbsp %><input name="p" size="20" value=p
|
|
||||||
/><% help "period-expressions"
|
|
||||||
%><input type="submit" name="submit" value="filter" style="display:none" />
|
|
||||||
<% resetlink %>
|
|
||||||
</form>
|
|
||||||
|
|
||||||
addform :: Hack.Env -> HSP XML
|
navlinks :: Request -> String -> String -> Hamlet HledgerWebAppRoutes
|
||||||
addform env = do
|
navlinks _ as ps = [$hamlet|
|
||||||
today <- io $ liftM showDate $ getCurrentDay
|
#navlinks
|
||||||
let inputs = Hack.Contrib.Request.inputs env
|
^transactionslink^ | $
|
||||||
date = decodeString $ fromMaybe today $ lookup "date" inputs
|
^registerlink^ | $
|
||||||
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
^balancelink^
|
||||||
<div>
|
|]
|
||||||
<div id="addform">
|
where
|
||||||
<form action="" method="POST">
|
transactionslink = navlink "transactions" TransactionsPage
|
||||||
<table border="0">
|
registerlink = navlink "register" RegisterPage
|
||||||
<tr>
|
balancelink = navlink "balance" BalancePage
|
||||||
<td>
|
navlink s dest = [$hamlet|%a.navlink!href=@?u@ $string.s$|]
|
||||||
Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %>
|
where u = (dest, [("a", as), ("p", ps)])
|
||||||
Description: <input size="35" name="desc" value=desc /><% nbsp %>
|
|
||||||
</td>
|
|
||||||
</tr>
|
|
||||||
<% transactionfields 1 env %>
|
|
||||||
<% transactionfields 2 env %>
|
|
||||||
<tr id="addbuttonrow"><td><input type="submit" value="add transaction"
|
|
||||||
/><% help "file-format" %></td></tr>
|
|
||||||
</table>
|
|
||||||
</form>
|
|
||||||
</div>
|
|
||||||
<br clear="all" />
|
|
||||||
</div>
|
|
||||||
|
|
||||||
help :: String -> HSP XML
|
searchform :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes
|
||||||
help topic = <a href=u>?</a>
|
searchform here a p = [$hamlet|
|
||||||
where u = printf "http://hledger.org/MANUAL.html%s" l :: String
|
%form#searchform!action=$string.action$
|
||||||
l | null topic = ""
|
search for: $
|
||||||
| otherwise = '#':topic
|
%input!name=a!size=20!value=$string.a$
|
||||||
|
^ahelp^ $
|
||||||
|
in reporting period: $
|
||||||
|
%input!name=p!size=20!value=$string.p$
|
||||||
|
^phelp^ $
|
||||||
|
%input!name=submit!type=submit!value=filter!style=display:none;
|
||||||
|
^resetlink^
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
action=""
|
||||||
|
ahelp = helplink "filter-patterns"
|
||||||
|
phelp = helplink "period-expressions"
|
||||||
|
resetlink
|
||||||
|
| null a && null p = [$hamlet||]
|
||||||
|
| otherwise = [$hamlet|%span#resetlink $
|
||||||
|
%a!href=@here@ reset|]
|
||||||
|
|
||||||
transactionfields :: Int -> Hack.Env -> HSP XML
|
helplink topic = [$hamlet|%a!href=$string.u$ ?|]
|
||||||
transactionfields n env = do
|
where u = manualurl ++ if null topic then "" else '#':topic
|
||||||
let inputs = Hack.Contrib.Request.inputs env
|
|
||||||
acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
|
|
||||||
amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
|
|
||||||
<tr>
|
|
||||||
<td>
|
|
||||||
<% nbsp %><% nbsp %>
|
|
||||||
Account: <input size="35" name=acctvar value=acct /><% nbsp %>
|
|
||||||
Amount: <input size="15" name=amtvar value=amt /><% nbsp %>
|
|
||||||
</td>
|
|
||||||
</tr>
|
|
||||||
where
|
|
||||||
numbered = (++ show n)
|
|
||||||
acctvar = numbered "acct"
|
|
||||||
amtvar = numbered "amt"
|
|
||||||
|
|
||||||
handleAddform :: Journal -> AppUnit
|
addform :: Request -> String -> String -> Hamlet HledgerWebAppRoutes
|
||||||
handleAddform j = do
|
addform _ _ _ = [$hamlet|
|
||||||
env <- getenv
|
%form#addform!action=$string.action$!method=POST
|
||||||
d <- io getCurrentDay
|
%table!border=0
|
||||||
t <- io getCurrentLocalTime
|
%tr
|
||||||
handle t $ validate env d
|
%td
|
||||||
where
|
Date:
|
||||||
validate :: Hack.Env -> Day -> Failing Transaction
|
%input!size=15!name=date!value=$string.date$
|
||||||
validate env today =
|
^datehelp^ $
|
||||||
let inputs = Hack.Contrib.Request.inputs env
|
Description:
|
||||||
date = decodeString $ fromMaybe "today" $ lookup "date" inputs
|
%input!size=35!name=desc!value=$string.desc$ $
|
||||||
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
^transactionfields1^
|
||||||
acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
|
^transactionfields2^
|
||||||
amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
|
%tr#addbuttonrow
|
||||||
acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
|
%td
|
||||||
amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
|
%input!type=submit!value=$string.addlabel$
|
||||||
validateDate "" = ["missing date"]
|
^addhelp^
|
||||||
validateDate _ = []
|
<br clear="all" />
|
||||||
validateDesc "" = ["missing description"]
|
|]
|
||||||
validateDesc _ = []
|
where
|
||||||
validateAcct1 "" = ["missing account 1"]
|
datehelp = helplink "dates"
|
||||||
validateAcct1 _ = []
|
addlabel = "add transaction"
|
||||||
validateAmt1 "" = ["missing amount 1"]
|
addhelp = helplink "file-format"
|
||||||
validateAmt1 _ = []
|
action=""
|
||||||
validateAcct2 "" = ["missing account 2"]
|
date = ""
|
||||||
validateAcct2 _ = []
|
desc = ""
|
||||||
validateAmt2 _ = []
|
transactionfields1 = transactionfields 1
|
||||||
amt1' = either (const missingamt) id $ parse someamount "" amt1
|
transactionfields2 = transactionfields 2
|
||||||
amt2' = either (const missingamt) id $ parse someamount "" amt2
|
|
||||||
(date', dateparseerr) = case fixSmartDateStrEither today date of
|
|
||||||
Right d -> (d, [])
|
|
||||||
Left e -> ("1900/01/01", [showDateParseError e])
|
|
||||||
t = Transaction {
|
|
||||||
tdate = parsedate date' -- date' must be parseable
|
|
||||||
,teffectivedate=Nothing
|
|
||||||
,tstatus=False
|
|
||||||
,tcode=""
|
|
||||||
,tdescription=desc
|
|
||||||
,tcomment=""
|
|
||||||
,tpostings=[
|
|
||||||
Posting False acct1 amt1' "" RegularPosting (Just t')
|
|
||||||
,Posting False acct2 amt2' "" RegularPosting (Just t')
|
|
||||||
]
|
|
||||||
,tpreceding_comment_lines=""
|
|
||||||
}
|
|
||||||
(t', balanceerr) = case balanceTransaction t of
|
|
||||||
Right t'' -> (t'', [])
|
|
||||||
Left e -> (t, [head $ lines e]) -- show just the error not the transaction
|
|
||||||
errs = concat [
|
|
||||||
validateDate date
|
|
||||||
,dateparseerr
|
|
||||||
,validateDesc desc
|
|
||||||
,validateAcct1 acct1
|
|
||||||
,validateAmt1 amt1
|
|
||||||
,validateAcct2 acct2
|
|
||||||
,validateAmt2 amt2
|
|
||||||
,balanceerr
|
|
||||||
]
|
|
||||||
in
|
|
||||||
case null errs of
|
|
||||||
False -> Failure errs
|
|
||||||
True -> Success t'
|
|
||||||
|
|
||||||
handle :: LocalTime -> Failing Transaction -> AppUnit
|
-- transactionfields :: Int -> Hamlet String
|
||||||
handle _ (Failure errs) = hsp errs addform
|
transactionfields n = [$hamlet|
|
||||||
handle ti (Success t) = do
|
%tr
|
||||||
io $ journalAddTransaction j t >>= journalReload
|
%td
|
||||||
ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
|
|
||||||
where msg = printf "Added transaction:\n%s" (show t)
|
Account:
|
||||||
|
%input!size=35!name=$string.acctvar$!value=$string.acct$
|
||||||
|
|
||||||
|
Amount:
|
||||||
|
%input!size=15!name=$string.amtvar$!value=$string.amt$ $
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
acct = ""
|
||||||
|
amt = ""
|
||||||
|
numbered = (++ show n)
|
||||||
|
acctvar = numbered "acct"
|
||||||
|
amtvar = numbered "amt"
|
||||||
|
|
||||||
|
postTransactionsPage :: Handler HledgerWebApp RepPlain
|
||||||
|
postTransactionsPage = do
|
||||||
|
today <- liftIO getCurrentDay
|
||||||
|
-- get form input values, or basic validation errors. E means an Either value.
|
||||||
|
dateE <- runFormPost $ catchFormError $ notEmpty $ required $ input "date"
|
||||||
|
descE <- runFormPost $ catchFormError $ required $ input "desc"
|
||||||
|
acct1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct1"
|
||||||
|
amt1E <- runFormPost $ catchFormError $ required $ input "amt1"
|
||||||
|
acct2E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct2"
|
||||||
|
amt2E <- runFormPost $ catchFormError $ required $ input "amt2"
|
||||||
|
-- supply defaults and parse date and amounts, or get errors.
|
||||||
|
let dateE' = either Left (either (\e -> Left [("date", showDateParseError e)]) Right . fixSmartDateStrEither today) dateE
|
||||||
|
amt1E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt1E -- XXX missingamt only when missing/empty
|
||||||
|
amt2E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt2E
|
||||||
|
strEs = [dateE', descE, acct1E, acct2E]
|
||||||
|
amtEs = [amt1E', amt2E']
|
||||||
|
errs = lefts strEs ++ lefts amtEs
|
||||||
|
[date,desc,acct1,acct2] = rights strEs
|
||||||
|
[amt1,amt2] = rights 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 ", " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) errs
|
||||||
|
redirect RedirectTemporary TransactionsPage
|
||||||
|
|
||||||
|
Right t -> do
|
||||||
|
let t' = txnTieKnot t -- XXX move into balanceTransaction
|
||||||
|
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||||
|
-- j' <- liftIO $ journalAddTransaction j t' >>= journalReload
|
||||||
|
-- liftIO $ putValue "hledger" "journal" j'
|
||||||
|
liftIO $ journalAddTransaction j t'
|
||||||
|
setMessage $ string $ printf "Added transaction:\n%s" (show t')
|
||||||
|
redirect RedirectTemporary TransactionsPage
|
||||||
|
|
||||||
nbsp :: XML
|
|
||||||
nbsp = cdata " "
|
|
||||||
|
|||||||
313
Hledger/Cli/Commands/Web610.hs
Normal file
313
Hledger/Cli/Commands/Web610.hs
Normal file
@ -0,0 +1,313 @@
|
|||||||
|
{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
|
||||||
|
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
|
||||||
|
{-|
|
||||||
|
A web-based UI.
|
||||||
|
-}
|
||||||
|
|
||||||
|
module Hledger.Cli.Commands.Web610
|
||||||
|
where
|
||||||
|
import Codec.Binary.UTF8.String (decodeString)
|
||||||
|
import Control.Applicative.Error (Failing(Success,Failure))
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Monad.Reader (ask)
|
||||||
|
import Data.IORef (newIORef, atomicModifyIORef)
|
||||||
|
import System.IO.Storage (withStore, putValue, getValue)
|
||||||
|
import Text.ParserCombinators.Parsec (parse)
|
||||||
|
|
||||||
|
import Hack.Contrib.Constants (_TextHtmlUTF8)
|
||||||
|
import Hack.Contrib.Response (set_content_type)
|
||||||
|
import qualified Hack (Env, http)
|
||||||
|
import qualified Hack.Contrib.Request (inputs, params, path)
|
||||||
|
import qualified Hack.Contrib.Response (redirect)
|
||||||
|
import Hack.Handler.SimpleServer (run)
|
||||||
|
|
||||||
|
import Network.Loli (loli, io, get, post, html, text, public)
|
||||||
|
import Network.Loli.Type (AppUnit)
|
||||||
|
import Network.Loli.Utils (update)
|
||||||
|
|
||||||
|
import HSP hiding (Request,catch)
|
||||||
|
import qualified HSP (Request(..))
|
||||||
|
|
||||||
|
import Hledger.Cli.Commands.Add (journalAddTransaction)
|
||||||
|
import Hledger.Cli.Commands.Balance
|
||||||
|
import Hledger.Cli.Commands.Histogram
|
||||||
|
import Hledger.Cli.Commands.Print
|
||||||
|
import Hledger.Cli.Commands.Register
|
||||||
|
import Hledger.Data
|
||||||
|
import Hledger.Read.Journal (someamount)
|
||||||
|
import Hledger.Cli.Options hiding (value)
|
||||||
|
#ifdef MAKE
|
||||||
|
import Paths_hledger_make (getDataFileName)
|
||||||
|
#else
|
||||||
|
import Paths_hledger (getDataFileName)
|
||||||
|
#endif
|
||||||
|
import Hledger.Cli.Utils
|
||||||
|
|
||||||
|
|
||||||
|
tcpport = 5000 :: Int
|
||||||
|
homeurl = printf "http://localhost:%d/" tcpport
|
||||||
|
browserdelay = 100000 -- microseconds
|
||||||
|
|
||||||
|
web :: [Opt] -> [String] -> Journal -> IO ()
|
||||||
|
web opts args j = do
|
||||||
|
unless (Debug `elem` opts) $ forkIO browser >> return ()
|
||||||
|
server opts args j
|
||||||
|
|
||||||
|
browser :: IO ()
|
||||||
|
browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
|
||||||
|
|
||||||
|
server :: [Opt] -> [String] -> Journal -> IO ()
|
||||||
|
server opts args j =
|
||||||
|
-- server initialisation
|
||||||
|
withStore "hledger" $ do -- IO ()
|
||||||
|
printf "starting web server on port %d\n" tcpport
|
||||||
|
t <- getCurrentLocalTime
|
||||||
|
webfiles <- getDataFileName "web"
|
||||||
|
putValue "hledger" "journal" j
|
||||||
|
run tcpport $ -- (Env -> IO Response) -> IO ()
|
||||||
|
\env -> do -- IO Response
|
||||||
|
-- general request handler
|
||||||
|
let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
|
||||||
|
args' = args ++ map decodeString (reqParamUtf8 env "a")
|
||||||
|
j' <- fromJust `fmap` getValue "hledger" "journal"
|
||||||
|
(changed, j'') <- io $ journalReloadIfChanged opts j'
|
||||||
|
when changed $ putValue "hledger" "journal" j''
|
||||||
|
-- declare path-specific request handlers
|
||||||
|
let command :: [String] -> ([Opt] -> FilterSpec -> Journal -> String) -> AppUnit
|
||||||
|
command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) j''
|
||||||
|
(loli $ -- State Loli () -> (Env -> IO Response)
|
||||||
|
do
|
||||||
|
get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
|
||||||
|
get "/register" $ command [] showRegisterReport
|
||||||
|
get "/histogram" $ command [] showHistogram
|
||||||
|
get "/transactions" $ ledgerpage [] j'' (showTransactions (optsToFilterSpec opts' args' t))
|
||||||
|
post "/transactions" $ handleAddform j''
|
||||||
|
get "/env" $ getenv >>= (text . show)
|
||||||
|
get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
|
||||||
|
get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
|
||||||
|
public (Just webfiles) ["/style.css"]
|
||||||
|
get "/" $ redirect ("transactions") Nothing
|
||||||
|
) env
|
||||||
|
|
||||||
|
getenv = ask
|
||||||
|
response = update
|
||||||
|
redirect u c = response $ Hack.Contrib.Response.redirect u c
|
||||||
|
|
||||||
|
reqParamUtf8 :: Hack.Env -> String -> [String]
|
||||||
|
reqParamUtf8 env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
|
||||||
|
|
||||||
|
ledgerpage :: [String] -> Journal -> (Journal -> String) -> AppUnit
|
||||||
|
ledgerpage msgs j f = do
|
||||||
|
env <- getenv
|
||||||
|
(_, j') <- io $ journalReloadIfChanged [] j
|
||||||
|
hsp msgs $ const <div><% addform env %><pre><% f j' %></pre></div>
|
||||||
|
|
||||||
|
-- | A loli directive to serve a string in pre tags within the hledger web
|
||||||
|
-- layout.
|
||||||
|
string :: [String] -> String -> AppUnit
|
||||||
|
string msgs s = hsp msgs $ const <pre><% s %></pre>
|
||||||
|
|
||||||
|
-- | A loli directive to serve a hsp template wrapped in the hledger web
|
||||||
|
-- layout. The hack environment is passed in to every hsp template as an
|
||||||
|
-- argument, since I don't see how to get it within the hsp monad.
|
||||||
|
-- A list of messages is also passed, eg for form errors.
|
||||||
|
hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
|
||||||
|
hsp msgs f = do
|
||||||
|
env <- getenv
|
||||||
|
let contenthsp = f env
|
||||||
|
pagehsp = hledgerpage env msgs title contenthsp
|
||||||
|
html =<< (io $ do
|
||||||
|
hspenv <- hackEnvToHspEnv env
|
||||||
|
(_,xml) <- runHSP html4Strict pagehsp hspenv
|
||||||
|
return $ addDoctype $ renderAsHTML xml)
|
||||||
|
response $ set_content_type _TextHtmlUTF8
|
||||||
|
where
|
||||||
|
title = ""
|
||||||
|
addDoctype = ("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n" ++)
|
||||||
|
hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
|
||||||
|
hackEnvToHspEnv env = do
|
||||||
|
x <- newIORef 0
|
||||||
|
let req = HSP.Request (reqParamUtf8 env) (Hack.http env)
|
||||||
|
num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
|
||||||
|
return $ HSPEnv req num
|
||||||
|
|
||||||
|
-- htmlToHsp :: Html -> HSP XML
|
||||||
|
-- htmlToHsp h = return $ cdata $ showHtml h
|
||||||
|
|
||||||
|
-- views
|
||||||
|
|
||||||
|
hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
|
||||||
|
hledgerpage env msgs title content =
|
||||||
|
<html>
|
||||||
|
<head>
|
||||||
|
<meta http-equiv = "Content-Type" content = "text/html; charset=utf-8" />
|
||||||
|
<link rel="stylesheet" type="text/css" href="/style.css" media="all" />
|
||||||
|
<title><% title %></title>
|
||||||
|
</head>
|
||||||
|
<body>
|
||||||
|
<% navbar env %>
|
||||||
|
<div id="messages"><% intercalate ", " msgs %></div>
|
||||||
|
<div id="content"><% content %></div>
|
||||||
|
</body>
|
||||||
|
</html>
|
||||||
|
|
||||||
|
navbar :: Hack.Env -> HSP XML
|
||||||
|
navbar env =
|
||||||
|
<div id="navbar">
|
||||||
|
<a href="http://hledger.org" id="hledgerorglink">hledger.org</a>
|
||||||
|
<% navlinks env %>
|
||||||
|
<% searchform env %>
|
||||||
|
<a href="http://hledger.org/MANUAL.html" id="helplink">help</a>
|
||||||
|
</div>
|
||||||
|
|
||||||
|
getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p
|
||||||
|
|
||||||
|
navlinks :: Hack.Env -> HSP XML
|
||||||
|
navlinks _ = do
|
||||||
|
a <- getParamOrNull "a"
|
||||||
|
p <- getParamOrNull "p"
|
||||||
|
let addparams=(++(printf "?a=%s&p=%s" a p))
|
||||||
|
link s = <a href=(addparams s) class="navlink"><% s %></a>
|
||||||
|
<div id="navlinks">
|
||||||
|
<% link "transactions" %> |
|
||||||
|
<% link "register" %> |
|
||||||
|
<% link "balance" %>
|
||||||
|
</div>
|
||||||
|
|
||||||
|
searchform :: Hack.Env -> HSP XML
|
||||||
|
searchform env = do
|
||||||
|
a <- getParamOrNull "a"
|
||||||
|
p <- getParamOrNull "p"
|
||||||
|
let resetlink | null a && null p = <span></span>
|
||||||
|
| otherwise = <span id="resetlink"><% nbsp %><a href=u>reset</a></span>
|
||||||
|
where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
|
||||||
|
<form action="" id="searchform">
|
||||||
|
<% nbsp %>search for:<% nbsp %><input name="a" size="20" value=a
|
||||||
|
/><% help "filter-patterns"
|
||||||
|
%><% nbsp %><% nbsp %>in reporting period:<% nbsp %><input name="p" size="20" value=p
|
||||||
|
/><% help "period-expressions"
|
||||||
|
%><input type="submit" name="submit" value="filter" style="display:none" />
|
||||||
|
<% resetlink %>
|
||||||
|
</form>
|
||||||
|
|
||||||
|
addform :: Hack.Env -> HSP XML
|
||||||
|
addform env = do
|
||||||
|
today <- io $ liftM showDate $ getCurrentDay
|
||||||
|
let inputs = Hack.Contrib.Request.inputs env
|
||||||
|
date = decodeString $ fromMaybe today $ lookup "date" inputs
|
||||||
|
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
||||||
|
<div>
|
||||||
|
<div id="addform">
|
||||||
|
<form action="" method="POST">
|
||||||
|
<table border="0">
|
||||||
|
<tr>
|
||||||
|
<td>
|
||||||
|
Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %>
|
||||||
|
Description: <input size="35" name="desc" value=desc /><% nbsp %>
|
||||||
|
</td>
|
||||||
|
</tr>
|
||||||
|
<% transactionfields 1 env %>
|
||||||
|
<% transactionfields 2 env %>
|
||||||
|
<tr id="addbuttonrow"><td><input type="submit" value="add transaction"
|
||||||
|
/><% help "file-format" %></td></tr>
|
||||||
|
</table>
|
||||||
|
</form>
|
||||||
|
</div>
|
||||||
|
<br clear="all" />
|
||||||
|
</div>
|
||||||
|
|
||||||
|
help :: String -> HSP XML
|
||||||
|
help topic = <a href=u>?</a>
|
||||||
|
where u = printf "http://hledger.org/MANUAL.html%s" l :: String
|
||||||
|
l | null topic = ""
|
||||||
|
| otherwise = '#':topic
|
||||||
|
|
||||||
|
transactionfields :: Int -> Hack.Env -> HSP XML
|
||||||
|
transactionfields n env = do
|
||||||
|
let inputs = Hack.Contrib.Request.inputs env
|
||||||
|
acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
|
||||||
|
amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
|
||||||
|
<tr>
|
||||||
|
<td>
|
||||||
|
<% nbsp %><% nbsp %>
|
||||||
|
Account: <input size="35" name=acctvar value=acct /><% nbsp %>
|
||||||
|
Amount: <input size="15" name=amtvar value=amt /><% nbsp %>
|
||||||
|
</td>
|
||||||
|
</tr>
|
||||||
|
where
|
||||||
|
numbered = (++ show n)
|
||||||
|
acctvar = numbered "acct"
|
||||||
|
amtvar = numbered "amt"
|
||||||
|
|
||||||
|
handleAddform :: Journal -> AppUnit
|
||||||
|
handleAddform j = do
|
||||||
|
env <- getenv
|
||||||
|
d <- io getCurrentDay
|
||||||
|
t <- io getCurrentLocalTime
|
||||||
|
handle t $ validate env d
|
||||||
|
where
|
||||||
|
validate :: Hack.Env -> Day -> Failing Transaction
|
||||||
|
validate env today =
|
||||||
|
let inputs = Hack.Contrib.Request.inputs env
|
||||||
|
date = decodeString $ fromMaybe "today" $ lookup "date" inputs
|
||||||
|
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
||||||
|
acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
|
||||||
|
amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
|
||||||
|
acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
|
||||||
|
amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
|
||||||
|
validateDate "" = ["missing date"]
|
||||||
|
validateDate _ = []
|
||||||
|
validateDesc "" = ["missing description"]
|
||||||
|
validateDesc _ = []
|
||||||
|
validateAcct1 "" = ["missing account 1"]
|
||||||
|
validateAcct1 _ = []
|
||||||
|
validateAmt1 "" = ["missing amount 1"]
|
||||||
|
validateAmt1 _ = []
|
||||||
|
validateAcct2 "" = ["missing account 2"]
|
||||||
|
validateAcct2 _ = []
|
||||||
|
validateAmt2 _ = []
|
||||||
|
amt1' = either (const missingamt) id $ parse someamount "" amt1
|
||||||
|
amt2' = either (const missingamt) id $ parse someamount "" amt2
|
||||||
|
(date', dateparseerr) = case fixSmartDateStrEither today date of
|
||||||
|
Right d -> (d, [])
|
||||||
|
Left e -> ("1900/01/01", [showDateParseError e])
|
||||||
|
t = Transaction {
|
||||||
|
tdate = parsedate date' -- date' must be parseable
|
||||||
|
,teffectivedate=Nothing
|
||||||
|
,tstatus=False
|
||||||
|
,tcode=""
|
||||||
|
,tdescription=desc
|
||||||
|
,tcomment=""
|
||||||
|
,tpostings=[
|
||||||
|
Posting False acct1 amt1' "" RegularPosting (Just t')
|
||||||
|
,Posting False acct2 amt2' "" RegularPosting (Just t')
|
||||||
|
]
|
||||||
|
,tpreceding_comment_lines=""
|
||||||
|
}
|
||||||
|
(t', balanceerr) = case balanceTransaction t of
|
||||||
|
Right t'' -> (t'', [])
|
||||||
|
Left e -> (t, [head $ lines e]) -- show just the error not the transaction
|
||||||
|
errs = concat [
|
||||||
|
validateDate date
|
||||||
|
,dateparseerr
|
||||||
|
,validateDesc desc
|
||||||
|
,validateAcct1 acct1
|
||||||
|
,validateAmt1 amt1
|
||||||
|
,validateAcct2 acct2
|
||||||
|
,validateAmt2 amt2
|
||||||
|
,balanceerr
|
||||||
|
]
|
||||||
|
in
|
||||||
|
case null errs of
|
||||||
|
False -> Failure errs
|
||||||
|
True -> Success t'
|
||||||
|
|
||||||
|
handle :: LocalTime -> Failing Transaction -> AppUnit
|
||||||
|
handle _ (Failure errs) = hsp errs addform
|
||||||
|
handle ti (Success t) = do
|
||||||
|
io $ journalAddTransaction j t >>= journalReload
|
||||||
|
ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
|
||||||
|
where msg = printf "Added transaction:\n%s" (show t)
|
||||||
|
|
||||||
|
nbsp :: XML
|
||||||
|
nbsp = cdata " "
|
||||||
@ -1,299 +0,0 @@
|
|||||||
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-}
|
|
||||||
{-|
|
|
||||||
A web-based UI.
|
|
||||||
-}
|
|
||||||
|
|
||||||
module Hledger.Cli.Commands.WebYesod
|
|
||||||
where
|
|
||||||
import Control.Concurrent -- (forkIO)
|
|
||||||
import Data.Either
|
|
||||||
import Network.Wai.Handler.SimpleServer (run)
|
|
||||||
import System.FilePath ((</>))
|
|
||||||
import System.IO.Storage (withStore, putValue, getValue)
|
|
||||||
import Text.Hamlet
|
|
||||||
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.Journal (someamount)
|
|
||||||
#ifdef MAKE
|
|
||||||
import Paths_hledger_make (getDataFileName)
|
|
||||||
#else
|
|
||||||
import Paths_hledger (getDataFileName)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
|
|
||||||
defhost = "localhost"
|
|
||||||
defport = 5000
|
|
||||||
browserstartdelay = 100000 -- microseconds
|
|
||||||
hledgerurl = "http://hledger.org"
|
|
||||||
manualurl = hledgerurl++"/MANUAL.html"
|
|
||||||
|
|
||||||
web :: [Opt] -> [String] -> Journal -> IO ()
|
|
||||||
web opts args j = do
|
|
||||||
let host = fromMaybe defhost $ hostFromOpts opts
|
|
||||||
port = fromMaybe defport $ portFromOpts opts
|
|
||||||
url = printf "http://%s:%d" host port :: String
|
|
||||||
unless (Debug `elem` opts) $ forkIO (browser url) >> return ()
|
|
||||||
server url port opts args j
|
|
||||||
|
|
||||||
browser :: String -> IO ()
|
|
||||||
browser url = putStrLn "starting web browser" >> threadDelay browserstartdelay >> openBrowserOn url >> return ()
|
|
||||||
|
|
||||||
server :: String -> Int -> [Opt] -> [String] -> Journal -> IO ()
|
|
||||||
server url port opts args j = do
|
|
||||||
printf "starting web server at %s\n" url
|
|
||||||
fp <- getDataFileName "web"
|
|
||||||
let app = HledgerWebApp{
|
|
||||||
appOpts=opts
|
|
||||||
,appArgs=args
|
|
||||||
,appJournal=j
|
|
||||||
,appWebdir=fp
|
|
||||||
,appRoot=url
|
|
||||||
}
|
|
||||||
withStore "hledger" $ do -- IO ()
|
|
||||||
putValue "hledger" "journal" j
|
|
||||||
toWaiApp app >>= run port
|
|
||||||
|
|
||||||
data HledgerWebApp = HledgerWebApp {
|
|
||||||
appOpts::[Opt]
|
|
||||||
,appArgs::[String]
|
|
||||||
,appJournal::Journal
|
|
||||||
,appWebdir::FilePath
|
|
||||||
,appRoot::String
|
|
||||||
}
|
|
||||||
|
|
||||||
instance Yesod HledgerWebApp where approot = appRoot
|
|
||||||
|
|
||||||
mkYesod "HledgerWebApp" [$parseRoutes|
|
|
||||||
/ IndexPage GET
|
|
||||||
/transactions TransactionsPage GET POST
|
|
||||||
/register RegisterPage GET
|
|
||||||
/balance BalancePage GET
|
|
||||||
/style.css StyleCss GET
|
|
||||||
/params ParamsDebug GET
|
|
||||||
|]
|
|
||||||
|
|
||||||
getParamsDebug = do
|
|
||||||
r <- getRequest
|
|
||||||
return $ RepHtml $ toContent $ show $ reqGetParams r
|
|
||||||
|
|
||||||
getIndexPage :: Handler HledgerWebApp ()
|
|
||||||
getIndexPage = redirect RedirectTemporary TransactionsPage
|
|
||||||
|
|
||||||
getStyleCss :: Handler HledgerWebApp RepPlain
|
|
||||||
getStyleCss = do
|
|
||||||
app <- getYesod
|
|
||||||
let dir = appWebdir app
|
|
||||||
s <- liftIO $ readFile $ dir </> "style.css"
|
|
||||||
header "Content-Type" "text/css"
|
|
||||||
return $ RepPlain $ toContent s
|
|
||||||
|
|
||||||
getTransactionsPage :: Handler HledgerWebApp RepHtml
|
|
||||||
getTransactionsPage = 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
|
|
||||||
params <- getParams
|
|
||||||
t <- liftIO $ getCurrentLocalTime
|
|
||||||
let head' x = if null x then "" else head x
|
|
||||||
as = head' $ params "a"
|
|
||||||
ps = head' $ params "p"
|
|
||||||
opts = appOpts app ++ [Period ps]
|
|
||||||
args = appArgs app ++ [as]
|
|
||||||
fspec = optsToFilterSpec opts args t
|
|
||||||
-- reload journal if changed
|
|
||||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
|
||||||
(changed, j') <- liftIO $ journalReloadIfChanged opts j
|
|
||||||
when changed $ liftIO $ putValue "hledger" "journal" j'
|
|
||||||
-- run the specified report using this request's params
|
|
||||||
let s = reportfn opts fspec j'
|
|
||||||
-- render the standard template
|
|
||||||
req <- getRequest
|
|
||||||
msg <- getMessage
|
|
||||||
Just here <- getRoute
|
|
||||||
hamletToRepHtml $ template here req msg as ps "hledger" s
|
|
||||||
|
|
||||||
template :: HledgerWebAppRoutes
|
|
||||||
-> Request -> Maybe (Html ()) -> String -> String
|
|
||||||
-> String -> String -> Hamlet HledgerWebAppRoutes
|
|
||||||
template here req msg as ps 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 req as ps
|
|
||||||
addform' = addform req as ps
|
|
||||||
stylesheet = StyleCss
|
|
||||||
metacontent = "text/html; charset=utf-8"
|
|
||||||
|
|
||||||
navbar :: HledgerWebAppRoutes -> Request -> String -> String -> Hamlet HledgerWebAppRoutes
|
|
||||||
navbar here req as ps = [$hamlet|
|
|
||||||
#navbar
|
|
||||||
%a#hledgerorglink!href=$string.hledgerurl$ hledger.org
|
|
||||||
^navlinks'^
|
|
||||||
^searchform'^
|
|
||||||
%a#helplink!href=$string.manualurl$ help
|
|
||||||
|]
|
|
||||||
where navlinks' = navlinks req as ps
|
|
||||||
searchform' = searchform here as ps
|
|
||||||
|
|
||||||
navlinks :: Request -> String -> String -> Hamlet HledgerWebAppRoutes
|
|
||||||
navlinks _ as ps = [$hamlet|
|
|
||||||
#navlinks
|
|
||||||
^transactionslink^ | $
|
|
||||||
^registerlink^ | $
|
|
||||||
^balancelink^
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
transactionslink = navlink "transactions" TransactionsPage
|
|
||||||
registerlink = navlink "register" RegisterPage
|
|
||||||
balancelink = navlink "balance" BalancePage
|
|
||||||
navlink s dest = [$hamlet|%a.navlink!href=@?u@ $string.s$|]
|
|
||||||
where u = (dest, [("a", as), ("p", ps)])
|
|
||||||
|
|
||||||
searchform :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes
|
|
||||||
searchform here a p = [$hamlet|
|
|
||||||
%form#searchform!action=$string.action$
|
|
||||||
search for: $
|
|
||||||
%input!name=a!size=20!value=$string.a$
|
|
||||||
^ahelp^ $
|
|
||||||
in reporting period: $
|
|
||||||
%input!name=p!size=20!value=$string.p$
|
|
||||||
^phelp^ $
|
|
||||||
%input!name=submit!type=submit!value=filter!style=display:none;
|
|
||||||
^resetlink^
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
action=""
|
|
||||||
ahelp = helplink "filter-patterns"
|
|
||||||
phelp = helplink "period-expressions"
|
|
||||||
resetlink
|
|
||||||
| null a && null p = [$hamlet||]
|
|
||||||
| otherwise = [$hamlet|%span#resetlink $
|
|
||||||
%a!href=@here@ reset|]
|
|
||||||
|
|
||||||
helplink topic = [$hamlet|%a!href=$string.u$ ?|]
|
|
||||||
where u = manualurl ++ if null topic then "" else '#':topic
|
|
||||||
|
|
||||||
addform :: Request -> String -> String -> Hamlet HledgerWebAppRoutes
|
|
||||||
addform _ _ _ = [$hamlet|
|
|
||||||
%form#addform!action=$string.action$!method=POST
|
|
||||||
%table!border=0
|
|
||||||
%tr
|
|
||||||
%td
|
|
||||||
Date:
|
|
||||||
%input!size=15!name=date!value=$string.date$
|
|
||||||
^datehelp^ $
|
|
||||||
Description:
|
|
||||||
%input!size=35!name=desc!value=$string.desc$ $
|
|
||||||
^transactionfields1^
|
|
||||||
^transactionfields2^
|
|
||||||
%tr#addbuttonrow
|
|
||||||
%td
|
|
||||||
%input!type=submit!value=$string.addlabel$
|
|
||||||
^addhelp^
|
|
||||||
<br clear="all" />
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
datehelp = helplink "dates"
|
|
||||||
addlabel = "add transaction"
|
|
||||||
addhelp = helplink "file-format"
|
|
||||||
action=""
|
|
||||||
date = ""
|
|
||||||
desc = ""
|
|
||||||
transactionfields1 = transactionfields 1
|
|
||||||
transactionfields2 = transactionfields 2
|
|
||||||
|
|
||||||
-- transactionfields :: Int -> Hamlet String
|
|
||||||
transactionfields n = [$hamlet|
|
|
||||||
%tr
|
|
||||||
%td
|
|
||||||
|
|
||||||
Account:
|
|
||||||
%input!size=35!name=$string.acctvar$!value=$string.acct$
|
|
||||||
|
|
||||||
Amount:
|
|
||||||
%input!size=15!name=$string.amtvar$!value=$string.amt$ $
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
acct = ""
|
|
||||||
amt = ""
|
|
||||||
numbered = (++ show n)
|
|
||||||
acctvar = numbered "acct"
|
|
||||||
amtvar = numbered "amt"
|
|
||||||
|
|
||||||
postTransactionsPage :: Handler HledgerWebApp RepPlain
|
|
||||||
postTransactionsPage = do
|
|
||||||
today <- liftIO getCurrentDay
|
|
||||||
-- get form input values, or basic validation errors. E means an Either value.
|
|
||||||
dateE <- runFormPost $ catchFormError $ notEmpty $ required $ input "date"
|
|
||||||
descE <- runFormPost $ catchFormError $ required $ input "desc"
|
|
||||||
acct1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct1"
|
|
||||||
amt1E <- runFormPost $ catchFormError $ required $ input "amt1"
|
|
||||||
acct2E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct2"
|
|
||||||
amt2E <- runFormPost $ catchFormError $ required $ input "amt2"
|
|
||||||
-- supply defaults and parse date and amounts, or get errors.
|
|
||||||
let dateE' = either Left (either (\e -> Left [("date", showDateParseError e)]) Right . fixSmartDateStrEither today) dateE
|
|
||||||
amt1E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt1E -- XXX missingamt only when missing/empty
|
|
||||||
amt2E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt2E
|
|
||||||
strEs = [dateE', descE, acct1E, acct2E]
|
|
||||||
amtEs = [amt1E', amt2E']
|
|
||||||
errs = lefts strEs ++ lefts amtEs
|
|
||||||
[date,desc,acct1,acct2] = rights strEs
|
|
||||||
[amt1,amt2] = rights 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 ", " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) errs
|
|
||||||
redirect RedirectTemporary TransactionsPage
|
|
||||||
|
|
||||||
Right t -> do
|
|
||||||
let t' = txnTieKnot t -- XXX move into balanceTransaction
|
|
||||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
|
||||||
-- j' <- liftIO $ journalAddTransaction j t' >>= journalReload
|
|
||||||
-- liftIO $ putValue "hledger" "journal" j'
|
|
||||||
liftIO $ journalAddTransaction j t'
|
|
||||||
setMessage $ string $ printf "Added transaction:\n%s" (show t')
|
|
||||||
redirect RedirectTemporary TransactionsPage
|
|
||||||
|
|
||||||
@ -70,7 +70,7 @@ main = do
|
|||||||
#ifdef VTY
|
#ifdef VTY
|
||||||
| cmd `isPrefixOf` "vty" = withJournalDo opts args cmd vty
|
| cmd `isPrefixOf` "vty" = withJournalDo opts args cmd vty
|
||||||
#endif
|
#endif
|
||||||
#if defined(WEB) || defined(WEBYESOD)
|
#if defined(WEB) || defined(WEB610)
|
||||||
| cmd `isPrefixOf` "web" = withJournalDo opts args cmd web
|
| cmd `isPrefixOf` "web" = withJournalDo opts args cmd web
|
||||||
#endif
|
#endif
|
||||||
#ifdef CHART
|
#ifdef CHART
|
||||||
|
|||||||
@ -38,7 +38,7 @@ usagehdr =
|
|||||||
#ifdef VTY
|
#ifdef VTY
|
||||||
" vty - run a simple curses-style UI\n" ++
|
" vty - run a simple curses-style UI\n" ++
|
||||||
#endif
|
#endif
|
||||||
#if defined(WEB) || defined(WEBYESOD)
|
#if defined(WEB) || defined(WEB610)
|
||||||
" web - run a simple web-based UI\n" ++
|
" web - run a simple web-based UI\n" ++
|
||||||
#endif
|
#endif
|
||||||
#ifdef CHART
|
#ifdef CHART
|
||||||
@ -81,7 +81,7 @@ options = [
|
|||||||
,Option "M" ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary"
|
,Option "M" ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary"
|
||||||
,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary"
|
,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary"
|
||||||
,Option "Y" ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary"
|
,Option "Y" ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary"
|
||||||
#if defined(WEB) || defined(WEBYESOD)
|
#ifdef WEB
|
||||||
,Option "" ["host"] (ReqArg Host "HOST") "web: use hostname HOST rather than localhost"
|
,Option "" ["host"] (ReqArg Host "HOST") "web: use hostname HOST rather than localhost"
|
||||||
,Option "" ["port"] (ReqArg Port "N") "web: use tcp port N rather than 5000"
|
,Option "" ["port"] (ReqArg Port "N") "web: use tcp port N rather than 5000"
|
||||||
#endif
|
#endif
|
||||||
@ -119,7 +119,7 @@ data Opt =
|
|||||||
MonthlyOpt |
|
MonthlyOpt |
|
||||||
QuarterlyOpt |
|
QuarterlyOpt |
|
||||||
YearlyOpt |
|
YearlyOpt |
|
||||||
#if defined(WEB) || defined(WEBYESOD)
|
#ifdef WEB
|
||||||
Host {value::String} |
|
Host {value::String} |
|
||||||
Port {value::String} |
|
Port {value::String} |
|
||||||
#endif
|
#endif
|
||||||
@ -224,7 +224,7 @@ displayExprFromOpts opts = listtomaybe $ optValuesForConstructor Display opts
|
|||||||
listtomaybe [] = Nothing
|
listtomaybe [] = Nothing
|
||||||
listtomaybe vs = Just $ last vs
|
listtomaybe vs = Just $ last vs
|
||||||
|
|
||||||
#if defined(WEB) || defined(WEBYESOD)
|
#ifdef WEB
|
||||||
-- | Get the value of the (last) host option, if any.
|
-- | Get the value of the (last) host option, if any.
|
||||||
hostFromOpts :: [Opt] -> Maybe String
|
hostFromOpts :: [Opt] -> Maybe String
|
||||||
hostFromOpts opts = listtomaybe $ optValuesForConstructor Host opts
|
hostFromOpts opts = listtomaybe $ optValuesForConstructor Host opts
|
||||||
|
|||||||
@ -70,8 +70,8 @@ configflags = tail [""
|
|||||||
,"vty"
|
,"vty"
|
||||||
#endif
|
#endif
|
||||||
#if defined(WEB)
|
#if defined(WEB)
|
||||||
,"web (using loli/hsp/simpleserver)"
|
|
||||||
#elif defined(WEBYESOD)
|
|
||||||
,"web (using yesod/hamlet/simpleserver)"
|
,"web (using yesod/hamlet/simpleserver)"
|
||||||
|
#elif defined(WEB610)
|
||||||
|
,"web (using loli/hsp/simpleserver)"
|
||||||
#endif
|
#endif
|
||||||
]
|
]
|
||||||
|
|||||||
@ -68,17 +68,21 @@ with the cabal-install tool:
|
|||||||
extra features (if you're new to cabal, I recommend you get the basic
|
extra features (if you're new to cabal, I recommend you get the basic
|
||||||
install working first, then add these one at a time):
|
install working first, then add these one at a time):
|
||||||
|
|
||||||
- `-fvty` - builds the [vty](#vty) command. (Not available on microsoft
|
- `-fchart` builds the [chart](#chart) command, enabling simple
|
||||||
windows.)
|
balance pie chart generation. This requires additional GTK/GHC
|
||||||
|
integration libraries (on ubuntu: `apt-get install libghc6-gtk-dev`)
|
||||||
- `-fweb` - builds the [web](#web) command (works with ghc 6.10).
|
and possibly other things - see the
|
||||||
|
|
||||||
- `-fwebyesod` - builds a newer version of the [web](#web) command (requires ghc 6.12).
|
|
||||||
|
|
||||||
- `-fchart` builds the [chart](#chart) command. This requires
|
|
||||||
additional GTK/GHC integration libraries (on ubuntu: `apt-get
|
|
||||||
install libghc6-gtk-dev`) and possibly other things - see the
|
|
||||||
[gtk2hs install docs](http://code.haskell.org/gtk2hs/INSTALL).
|
[gtk2hs install docs](http://code.haskell.org/gtk2hs/INSTALL).
|
||||||
|
At present this add a lot of build complexity for not much gain.
|
||||||
|
|
||||||
|
- `-fvty` - builds the [vty](#vty) command, enabling a basic
|
||||||
|
curses-style user interface. This does not work on microsoft
|
||||||
|
windows, unless possibly with cygwin.
|
||||||
|
|
||||||
|
- `-fweb` - builds the [web](#web) command, enabling a web-based user
|
||||||
|
interface (requires ghc 6.12). If you are stuck with ghc 6.10, you
|
||||||
|
can use `-fweb610` instead, to build an older version of the
|
||||||
|
[web](#web) command.
|
||||||
|
|
||||||
If you have any trouble, proceed at once to [Troubleshooting](#troubleshooting) for help!
|
If you have any trouble, proceed at once to [Troubleshooting](#troubleshooting) for help!
|
||||||
|
|
||||||
@ -115,7 +119,7 @@ on:
|
|||||||
hledger histogram # transactions per day, or other interval
|
hledger histogram # transactions per day, or other interval
|
||||||
hledger add # add some new transactions to the ledger file
|
hledger add # add some new transactions to the ledger file
|
||||||
hledger vty # curses ui, if installed with -fvty
|
hledger vty # curses ui, if installed with -fvty
|
||||||
hledger web # web ui, if installed with -fweb or -fwebyesod
|
hledger web # web ui, if installed with -fweb or -fweb610
|
||||||
hledger chart # make a balance chart, if installed with -fchart
|
hledger chart # make a balance chart, if installed with -fchart
|
||||||
|
|
||||||
You'll find more examples below.
|
You'll find more examples below.
|
||||||
@ -280,8 +284,6 @@ Examples:
|
|||||||
|
|
||||||
##### chart
|
##### chart
|
||||||
|
|
||||||
(optional feature)
|
|
||||||
|
|
||||||
The chart command saves a pie chart of your top account balances to an
|
The chart command saves a pie chart of your top account balances to an
|
||||||
image file (usually "hledger.png", or use -o/--output FILE). You can
|
image file (usually "hledger.png", or use -o/--output FILE). You can
|
||||||
adjust the image resolution with --size=WIDTHxHEIGHT, and the number of
|
adjust the image resolution with --size=WIDTHxHEIGHT, and the number of
|
||||||
@ -303,6 +305,8 @@ Examples:
|
|||||||
$ hledger chart ^expenses -o balance.png --size 1000x600 --items 20
|
$ hledger chart ^expenses -o balance.png --size 1000x600 --items 20
|
||||||
$ for m in 01 02 03 04 05 06 07 08 09 10 11 12; do hledger -p 2009/$m chart ^expenses --depth 2 -o expenses-2009$m.png --size 400x300; done
|
$ for m in 01 02 03 04 05 06 07 08 09 10 11 12; do hledger -p 2009/$m chart ^expenses --depth 2 -o expenses-2009$m.png --size 400x300; done
|
||||||
|
|
||||||
|
This is an optional feature; see [installing](#installing).
|
||||||
|
|
||||||
##### histogram
|
##### histogram
|
||||||
|
|
||||||
The histogram command displays a quick bar chart showing transaction
|
The histogram command displays a quick bar chart showing transaction
|
||||||
@ -323,8 +327,6 @@ Examples:
|
|||||||
|
|
||||||
##### vty
|
##### vty
|
||||||
|
|
||||||
(optional feature)
|
|
||||||
|
|
||||||
The vty command starts hledger's curses (full-screen, text) user interface,
|
The vty command starts hledger's curses (full-screen, text) user interface,
|
||||||
which allows interactive navigation of the print/register/balance
|
which allows interactive navigation of the print/register/balance
|
||||||
reports. This lets you browse around your numbers and get quick insights
|
reports. This lets you browse around your numbers and get quick insights
|
||||||
@ -335,6 +337,8 @@ Examples:
|
|||||||
$ hledger vty
|
$ hledger vty
|
||||||
$ hledger vty -BE food
|
$ hledger vty -BE food
|
||||||
|
|
||||||
|
This is an optional feature; see [installing](#installing).
|
||||||
|
|
||||||
#### Modifying commands
|
#### Modifying commands
|
||||||
|
|
||||||
The following commands can alter your ledger file.
|
The following commands can alter your ledger file.
|
||||||
@ -350,32 +354,25 @@ $ hledger add $ hledger add accounts:personal:bob
|
|||||||
|
|
||||||
##### web
|
##### web
|
||||||
|
|
||||||
(optional feature)
|
|
||||||
|
|
||||||
The web command starts hledger's web interface, and tries to open a web
|
The web command starts hledger's web interface, and tries to open a web
|
||||||
browser to view it (if this fails, you'll have to visit the indicated url
|
browser to view it. (If this fails, you'll have to manually visit the url
|
||||||
yourself.) The web ui combines the features of the print, register,
|
it displays.) The web interface combines the features of the print,
|
||||||
balance and add commands.
|
register, balance and add commands, and adds a general edit command.
|
||||||
|
|
||||||
Note there are two alternate implementations of the web command - the old
|
This is an optional feature. Note there is also an older implementation of
|
||||||
one, built with `-fweb`:
|
the web command which does not provide edit. See [installing](#installing).
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
|
||||||
$ hledger web
|
$ hledger web
|
||||||
|
|
||||||
and the new one, built with `-fwebyesod`, which you run in the same way:
|
|
||||||
|
|
||||||
$ hledger web
|
|
||||||
|
|
||||||
We will assume the latter in the rest of these docs. Some more examples:
|
|
||||||
|
|
||||||
$ hledger web -E -B p 'this year'
|
$ hledger web -E -B p 'this year'
|
||||||
$ hledger web --base-url http://this.vhost.com --port 5010 --debug -f my.journal
|
$ hledger web --base-url http://this.vhost.com --port 5010 --debug -f my.journal
|
||||||
|
|
||||||
The new web ui adds an edit command. Warning: this is the first hledger
|
About the edit command: warning, this is the first hledger feature which
|
||||||
feature which can alter your existing journal data. You can edit, or
|
can alter your existing journal data. You can edit, or erase, the journal
|
||||||
ERASE, the (top-level) journal file through the web ui. There is no access
|
file through the web ui. There is no access control. A numbered backup of
|
||||||
control. A numbered backup of the file will be saved at each edit, in
|
the file will be saved at each edit, in normal circumstances (eg if file
|
||||||
normal circumstances (eg if file permissions allow, disk is not full, etc.)
|
permissions allow, disk is not full, etc.)
|
||||||
|
|
||||||
#### Other commands
|
#### Other commands
|
||||||
|
|
||||||
@ -884,8 +881,8 @@ sailing. Here are some known issues and things to try:
|
|||||||
|
|
||||||
- **Did you cabal update ?** If you didn't already, ``cabal update`` and try again.
|
- **Did you cabal update ?** If you didn't already, ``cabal update`` and try again.
|
||||||
|
|
||||||
- **Do you have a new enough version of GHC ?** As of 2010, 6.10 and 6.12
|
- **Do you have a new enough version of GHC ?** hledger supports GHC 6.10
|
||||||
are supported, 6.8 might or might not work.
|
and 6.12. Building with the `-fweb` flag requires 6.12 or greater.
|
||||||
|
|
||||||
- **Do you have a new enough version of cabal-install ?**
|
- **Do you have a new enough version of cabal-install ?**
|
||||||
Recent versions tend to be better at resolving dependencies. The error
|
Recent versions tend to be better at resolving dependencies. The error
|
||||||
@ -894,11 +891,12 @@ sailing. Here are some known issues and things to try:
|
|||||||
|
|
||||||
$ cabal update
|
$ cabal update
|
||||||
$ cabal install cabal-install
|
$ cabal install cabal-install
|
||||||
|
$ cabal clean
|
||||||
|
|
||||||
then try installing hledger again.
|
then try installing hledger again.
|
||||||
|
|
||||||
- **Could not run trhsx.**
|
- **Could not run trhsx.**
|
||||||
You are installing with `-fweb`, which needs to run the ``trhsx`` executable.
|
You are installing with `-fweb610`, which needs to run the ``trhsx`` executable.
|
||||||
It is installed by the hsx package in ~/.cabal/bin, which needs to be in
|
It is installed by the hsx package in ~/.cabal/bin, which needs to be in
|
||||||
your path.
|
your path.
|
||||||
|
|
||||||
@ -921,10 +919,14 @@ sailing. Here are some known issues and things to try:
|
|||||||
|
|
||||||
you are probably on a mac with macports libraries installed, causing
|
you are probably on a mac with macports libraries installed, causing
|
||||||
[this issue](http://hackage.haskell.org/trac/ghc/ticket/4068).
|
[this issue](http://hackage.haskell.org/trac/ghc/ticket/4068).
|
||||||
To work around, add this --extra-lib-dirs flag:
|
To work around temporarily, add this --extra-lib-dirs flag:
|
||||||
|
|
||||||
$ cabal install hledger --extra-lib-dirs=/usr/lib
|
$ cabal install hledger --extra-lib-dirs=/usr/lib
|
||||||
|
|
||||||
|
or permanently, add this to ~/.cabal/config:
|
||||||
|
|
||||||
|
extra-lib-dirs: /usr/lib
|
||||||
|
|
||||||
- **A ghc: panic! (the 'impossible' happened)** might be
|
- **A ghc: panic! (the 'impossible' happened)** might be
|
||||||
[this issue](http://hackage.haskell.org/trac/ghc/ticket/3862)
|
[this issue](http://hackage.haskell.org/trac/ghc/ticket/3862)
|
||||||
|
|
||||||
@ -949,16 +951,13 @@ sailing. Here are some known issues and things to try:
|
|||||||
Look for the cause of the failure near the end of the output. If it's
|
Look for the cause of the failure near the end of the output. If it's
|
||||||
not apparent, try again with `-v2` or `-v3` for more verbose output.
|
not apparent, try again with `-v2` or `-v3` for more verbose output.
|
||||||
|
|
||||||
- **cabal fails to reconcile dependencies.**
|
- **cabal fails to resolve dependencies.**
|
||||||
This could be related to your GHC version: hledger requires at least GHC
|
It's possible for cabal to get confused, eg if you have
|
||||||
6.10 and `-fwebyesod` requires 6.12 or greater.
|
installed/updated many cabal package versions or GHC itself. You can
|
||||||
|
sometimes work around this by using cabal install's `--constraint`
|
||||||
Also, it's possible for cabal to get confused, eg if you have
|
option. Another (drastic) way is to purge all unnecessary package
|
||||||
installed/updated many cabal package versions or GHC itself. You can
|
versions by removing (or renaming) ~/.ghc, then trying cabal install
|
||||||
sometimes work around this by using cabal install's `--constraint`
|
again.
|
||||||
option. Another (drastic) way is to purge all unnecessary package
|
|
||||||
versions by removing (or renaming) ~/.ghc, then trying cabal install
|
|
||||||
again.
|
|
||||||
|
|
||||||
#### Usage issues
|
#### Usage issues
|
||||||
|
|
||||||
|
|||||||
4
Makefile
4
Makefile
@ -1,8 +1,8 @@
|
|||||||
# hledger project makefile
|
# hledger project makefile
|
||||||
|
|
||||||
# optional features described in MANUAL, comment out if you don't have the libs
|
# optional features described in MANUAL, comment out if you don't have the libs
|
||||||
#OPTFLAGS=-DCHART -DVTY -DWEBHAPPSTACK
|
#OPTFLAGS=-DCHART -DVTY -DWEB
|
||||||
OPTFLAGS=-DVTY -DWEB
|
OPTFLAGS=-DWEB
|
||||||
#OPTFLAGS=
|
#OPTFLAGS=
|
||||||
|
|
||||||
# command to run during "make ci"
|
# command to run during "make ci"
|
||||||
|
|||||||
@ -25,6 +25,8 @@ build-type: Simple
|
|||||||
-- sample.timelog
|
-- sample.timelog
|
||||||
|
|
||||||
library
|
library
|
||||||
|
-- should set patchlevel here as in Makefile
|
||||||
|
cpp-options: -DPATCHLEVEL=0
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Hledger.Data
|
Hledger.Data
|
||||||
Hledger.Data.Account
|
Hledger.Data.Account
|
||||||
@ -58,9 +60,6 @@ library
|
|||||||
,utf8-string >= 0.3
|
,utf8-string >= 0.3
|
||||||
,HUnit
|
,HUnit
|
||||||
|
|
||||||
-- should set patchlevel here as in Makefile
|
|
||||||
cpp-options: -DPATCHLEVEL=0
|
|
||||||
|
|
||||||
-- source-repository head
|
-- source-repository head
|
||||||
-- type: darcs
|
-- type: darcs
|
||||||
-- location: http://joyful.com/repos/hledger
|
-- location: http://joyful.com/repos/hledger
|
||||||
|
|||||||
@ -18,7 +18,7 @@ maintainer: Simon Michael <simon@joyful.com>
|
|||||||
homepage: http://hledger.org
|
homepage: http://hledger.org
|
||||||
bug-reports: http://code.google.com/p/hledger/issues
|
bug-reports: http://code.google.com/p/hledger/issues
|
||||||
stability: experimental
|
stability: experimental
|
||||||
tested-with: GHC==6.10
|
tested-with: GHC==6.10, GHC==6.12
|
||||||
cabal-version: >= 1.2
|
cabal-version: >= 1.2
|
||||||
build-type: Custom
|
build-type: Custom
|
||||||
data-dir: data
|
data-dir: data
|
||||||
@ -35,24 +35,26 @@ extra-source-files:
|
|||||||
data/sample.timelog
|
data/sample.timelog
|
||||||
data/sample.rules
|
data/sample.rules
|
||||||
|
|
||||||
|
flag chart
|
||||||
|
description: enable simple balance pie chart generation
|
||||||
|
default: False
|
||||||
|
|
||||||
flag vty
|
flag vty
|
||||||
description: enable the curses ui
|
description: enable the curses-style ui
|
||||||
default: False
|
default: False
|
||||||
|
|
||||||
flag web
|
flag web
|
||||||
description: enable the web ui (using loli/hsp/simpleserver, works with ghc 6.10)
|
|
||||||
default: False
|
|
||||||
|
|
||||||
flag webyesod
|
|
||||||
description: enable the web ui (using yesod/hamlet/simpleserver, requires ghc 6.12)
|
description: enable the web ui (using yesod/hamlet/simpleserver, requires ghc 6.12)
|
||||||
default: False
|
default: False
|
||||||
|
|
||||||
flag chart
|
flag web610
|
||||||
description: enable the pie chart generation
|
description: enable the web ui (using loli/hsp/simpleserver, works with ghc 6.10)
|
||||||
default: False
|
default: False
|
||||||
|
|
||||||
executable hledger
|
executable hledger
|
||||||
main-is: hledger.hs
|
main-is: hledger.hs
|
||||||
|
-- should set patchlevel here as in Makefile
|
||||||
|
cpp-options: -DPATCHLEVEL=0
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_hledger
|
Paths_hledger
|
||||||
Hledger.Cli.Main
|
Hledger.Cli.Main
|
||||||
@ -87,8 +89,12 @@ executable hledger
|
|||||||
,time
|
,time
|
||||||
,utf8-string >= 0.3
|
,utf8-string >= 0.3
|
||||||
|
|
||||||
-- should set patchlevel here as in Makefile
|
if flag(chart)
|
||||||
cpp-options: -DPATCHLEVEL=0
|
cpp-options: -DCHART
|
||||||
|
other-modules:Hledger.Cli.Commands.Chart
|
||||||
|
build-depends:
|
||||||
|
Chart >= 0.11
|
||||||
|
,colour
|
||||||
|
|
||||||
if flag(vty)
|
if flag(vty)
|
||||||
cpp-options: -DVTY
|
cpp-options: -DVTY
|
||||||
@ -99,6 +105,18 @@ executable hledger
|
|||||||
if flag(web)
|
if flag(web)
|
||||||
cpp-options: -DWEB
|
cpp-options: -DWEB
|
||||||
other-modules:Hledger.Cli.Commands.Web
|
other-modules:Hledger.Cli.Commands.Web
|
||||||
|
build-depends:
|
||||||
|
bytestring >= 0.9.1 && < 0.9.2
|
||||||
|
,blaze-html >= 0.1.1 && < 0.2
|
||||||
|
,hamlet >= 0.3.1 && < 0.4
|
||||||
|
,io-storage >= 0.3 && < 0.4
|
||||||
|
,wai >= 0.1 && < 0.2
|
||||||
|
,wai-extra >= 0.1 && < 0.2
|
||||||
|
,yesod >= 0.3.1 && < 0.4
|
||||||
|
|
||||||
|
if flag(web610)
|
||||||
|
cpp-options: -DWEB610
|
||||||
|
other-modules:Hledger.Cli.Commands.Web610
|
||||||
build-depends:
|
build-depends:
|
||||||
hsp
|
hsp
|
||||||
,hsx
|
,hsx
|
||||||
@ -111,27 +129,13 @@ executable hledger
|
|||||||
,HTTP >= 4000.0
|
,HTTP >= 4000.0
|
||||||
,applicative-extras
|
,applicative-extras
|
||||||
|
|
||||||
if flag(webyesod)
|
-- modules and dependencies below should be as above, except
|
||||||
cpp-options: -DWEBYESOD
|
-- chart, vty, web etc. are not presently exposed as library functions
|
||||||
other-modules:Hledger.Cli.Commands.WebYesod
|
|
||||||
build-depends:
|
|
||||||
bytestring >= 0.9.1 && < 0.9.2
|
|
||||||
,blaze-html >= 0.1.1 && < 0.2
|
|
||||||
,hamlet >= 0.3.1 && < 0.4
|
|
||||||
,io-storage >= 0.3 && < 0.4
|
|
||||||
,wai >= 0.1 && < 0.2
|
|
||||||
,wai-extra >= 0.1 && < 0.2
|
|
||||||
,yesod >= 0.3.1 && < 0.4
|
|
||||||
|
|
||||||
if flag(chart)
|
|
||||||
cpp-options: -DCHART
|
|
||||||
other-modules:Hledger.Cli.Commands.Chart
|
|
||||||
build-depends:
|
|
||||||
Chart >= 0.11
|
|
||||||
,colour
|
|
||||||
|
|
||||||
library
|
library
|
||||||
|
-- should set patchlevel here as in Makefile
|
||||||
|
cpp-options: -DPATCHLEVEL=0
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
|
Paths_hledger
|
||||||
Hledger.Cli.Main
|
Hledger.Cli.Main
|
||||||
Hledger.Cli.Options
|
Hledger.Cli.Options
|
||||||
Hledger.Cli.Tests
|
Hledger.Cli.Tests
|
||||||
@ -164,37 +168,6 @@ library
|
|||||||
,time
|
,time
|
||||||
,utf8-string >= 0.3
|
,utf8-string >= 0.3
|
||||||
|
|
||||||
-- should set patchlevel here as in Makefile
|
|
||||||
cpp-options: -DPATCHLEVEL=0
|
|
||||||
|
|
||||||
if flag(vty)
|
|
||||||
cpp-options: -DVTY
|
|
||||||
exposed-modules:Hledger.Cli.Commands.Vty
|
|
||||||
build-depends:
|
|
||||||
vty >= 4.0.0.1
|
|
||||||
|
|
||||||
if flag(web)
|
|
||||||
cpp-options: -DWEB
|
|
||||||
exposed-modules:Hledger.Cli.Commands.Web
|
|
||||||
build-depends:
|
|
||||||
hsp
|
|
||||||
,hsx
|
|
||||||
,xhtml >= 3000.2
|
|
||||||
,loli
|
|
||||||
,io-storage
|
|
||||||
,hack-contrib
|
|
||||||
,hack
|
|
||||||
,hack-handler-simpleserver
|
|
||||||
,HTTP >= 4000.0
|
|
||||||
,applicative-extras
|
|
||||||
|
|
||||||
if flag(chart)
|
|
||||||
cpp-options: -DCHART
|
|
||||||
exposed-modules:Hledger.Cli.Commands.Chart
|
|
||||||
build-depends:
|
|
||||||
Chart >= 0.11
|
|
||||||
,colour
|
|
||||||
|
|
||||||
-- source-repository head
|
-- source-repository head
|
||||||
-- type: darcs
|
-- type: darcs
|
||||||
-- location: http://joyful.com/repos/hledger
|
-- location: http://joyful.com/repos/hledger
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user