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

web: transaction adding now works in -fwebyesod

Browse Source
This commit is contained in:
Simon Michael 2010-07-01 21:03:44 +00:00
parent 40b6e7bc0d
commit 93be03d883
1 changed files with 111 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

235
Hledger/Cli/Commands/WebYesod.hs
View File

@ -5,23 +5,24 @@ A web-based UI.
module Hledger.Cli.Commands.WebYesod module Hledger.Cli.Commands.WebYesod
where where
import Control.Concurrent -- (forkIO) import Control.Concurrent -- (forkIO)
import qualified Data.ByteString.Char8 as B
import Data.Either
import qualified Network.Wai (Request(pathInfo)) import qualified Network.Wai (Request(pathInfo))
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.IO.Storage (withStore, putValue, getValue) import System.IO.Storage (withStore, putValue, getValue)
import Text.Hamlet import Text.Hamlet
import qualified Data.ByteString.Char8 as B import Text.ParserCombinators.Parsec (parse)
import Yesod import Yesod
-- 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.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.Options hiding (value)
import Hledger.Cli.Utils import Hledger.Cli.Utils
import Hledger.Data import Hledger.Data
import Hledger.Read.Journal (someamount)
#ifdef MAKE #ifdef MAKE
import Paths_hledger_make (getDataFileName) import Paths_hledger_make (getDataFileName)
#else #else
@ -90,9 +91,6 @@ getIndexPage = redirect RedirectTemporary TransactionsPage
getTransactionsPage :: Handler HledgerWebApp RepHtml getTransactionsPage :: Handler HledgerWebApp RepHtml
getTransactionsPage = withLatestJournalRender (const showTransactions) getTransactionsPage = withLatestJournalRender (const showTransactions)
postTransactionsPage :: Handler HledgerWebApp RepHtml
postTransactionsPage = withLatestJournalRender (const showTransactions)
getRegisterPage :: Handler HledgerWebApp RepHtml getRegisterPage :: Handler HledgerWebApp RepHtml
getRegisterPage = withLatestJournalRender showRegisterReport getRegisterPage = withLatestJournalRender showRegisterReport
@ -104,17 +102,23 @@ withLatestJournalRender f = do
app <- getYesod app <- getYesod
req <- getRequest req <- getRequest
params <- getParams params <- getParams
msg <- getMessage
t <- liftIO $ getCurrentLocalTime t <- liftIO $ getCurrentLocalTime
-- today <- liftIO $ liftM showDate $ getCurrentDay
let as = params "a" let as = params "a"
ps = params "p" ps = params "p"
opts = appOpts app ++ [Period $ unwords ps] opts = appOpts app ++ [Period $ unwords ps]
args = appArgs app ++ as args = appArgs app ++ as
fs = optsToFilterSpec opts args t fs = optsToFilterSpec opts args t
-- date = fromMaybe (decodeString today) $ getParam "date"
-- desc = fromMaybe "" $ getParam "desc"
-- acct = fromMaybe "" $ getParam "acctvar"
-- amt = fromMaybe "" $ getParam "amtvar"
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
(changed, j') <- liftIO $ journalReloadIfChanged opts j (changed, j') <- liftIO $ journalReloadIfChanged opts j
when changed $ liftIO $ putValue "hledger" "journal" j' when changed $ liftIO $ putValue "hledger" "journal" j'
let content = f opts fs j' let content = f opts fs j'
return $ RepHtml $ toContent $ renderHamlet id $ template req as ps "" content return $ RepHtml $ toContent $ renderHamlet id $ template req msg as ps "hledger" content
-- hamletToRepHtml $ template "" s -- hamletToRepHtml $ template "" s
getStyleCss :: Handler HledgerWebApp RepPlain getStyleCss :: Handler HledgerWebApp RepPlain
@ -125,8 +129,8 @@ getStyleCss = do
header "Content-Type" "text/css" header "Content-Type" "text/css"
return $ RepPlain $ toContent s return $ RepPlain $ toContent s
template :: Request -> [String] -> [String] -> String -> String -> Hamlet String template :: Request -> Maybe (Html ()) -> [String] -> [String] -> String -> String -> Hamlet String
template req as ps t s = [$hamlet| template req msg as ps t s = [$hamlet|
!!! !!!
%html %html
%head %head
@ -135,12 +139,14 @@ template req as ps t s = [$hamlet|
%title $string.t$ %title $string.t$
%body %body
^navbar'^ ^navbar'^
#messages $string.msgs$ #messages $m$
^addform'^
#content #content
%pre $string.s$ %pre $string.s$
|] |]
where msgs = intercalate ", " [] where m = fromMaybe (string "") msg
navbar' = navbar req as ps navbar' = navbar req as ps
addform' = addform req as ps
stylesheet = "/style.css" stylesheet = "/style.css"
metacontent = "text/html; charset=utf-8" metacontent = "text/html; charset=utf-8"
@ -196,119 +202,100 @@ searchform req as ps = [$hamlet|
helplink topic = [$hamlet|%a!href=@u@ ?|] helplink topic = [$hamlet|%a!href=@u@ ?|]
where u = manualurl ++ if null topic then "" else '#':topic where u = manualurl ++ if null topic then "" else '#':topic
{- addform :: Request -> [String] -> [String] -> Hamlet String
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
addform :: Hack.Env -> HSP XML transactionfields :: Int -> Hamlet String
addform env = do transactionfields n = [$hamlet|
today <- io $ liftM showDate $ getCurrentDay %tr
let inputs = Hack.Contrib.Request.inputs env %td
date = decodeString $ fromMaybe today $ lookup "date" inputs &nbsp;&nbsp;
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs Account:
<div> %input!size=35!name=$string.acctvar$!value=$string.acct$
<div id="addform"> &nbsp;
<form action="" method="POST"> Amount:
<table border="0"> %input!size=15!name=$string.amtvar$!value=$string.amt$ $
<tr> |]
<td> where
Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %> acct = ""
Description: <input size="35" name="desc" value=desc /><% nbsp %> amt = ""
</td> numbered = (++ show n)
</tr> acctvar = numbered "acct"
<% transactionfields 1 env %> amtvar = numbered "amt"
<% 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>
transactionfields :: Int -> Hack.Env -> HSP XML postTransactionsPage :: Handler HledgerWebApp RepPlain
transactionfields n env = do postTransactionsPage = do
let inputs = Hack.Contrib.Request.inputs env today <- liftIO getCurrentDay
acct = decodeString $ fromMaybe "" $ lookup acctvar inputs -- get form input values, or basic validation errors. E suffix means an Either value.
amt = decodeString $ fromMaybe "" $ lookup amtvar inputs dateE <- runFormPost $ catchFormError $ notEmpty $ required $ input "date"
<tr> descE <- runFormPost $ catchFormError $ required $ input "desc"
<td> acct1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct1"
<% nbsp %><% nbsp %> amt1E <- runFormPost $ catchFormError $ required $ input "amt1"
Account: <input size="35" name=acctvar value=acct /><% nbsp %> acct2E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct2"
Amount: <input size="15" name=amtvar value=amt /><% nbsp %> amt2E <- runFormPost $ catchFormError $ required $ input "amt2"
</td> -- supply defaults and parse date and amounts, or get errors.
</tr> let dateE' = either Left (either (\e -> Left [("date", showDateParseError e)]) Right . fixSmartDateStrEither today) dateE
where amt1E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt1E -- XXX missingamt only when missing/empty
numbered = (++ show n) amt2E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt2E
acctvar = numbered "acct" strEs = [dateE', descE, acct1E, acct2E]
amtvar = numbered "amt" 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
handleAddform :: Journal -> AppUnit Right t -> do
handleAddform j = do let t' = txnTieKnot t -- XXX move into balanceTransaction
env <- getenv j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
d <- io getCurrentDay j' <- liftIO $ journalAddTransaction j t' >>= journalReload
t <- io getCurrentLocalTime liftIO $ putValue "hledger" "journal" j'
handle t $ validate env d setMessage $ string $ printf "Added transaction:\n%s" (show t')
where redirect RedirectTemporary TransactionsPage
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 >> reload j
ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
where msg = printf "Added transaction:\n%s" (show t)
-}