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|
addform :: Hack.Env -> HSP XML %form#addform!action=$string.action$!method=POST
addform env = do %table!border=0
today <- io $ liftM showDate $ getCurrentDay %tr
let inputs = Hack.Contrib.Request.inputs env %td
date = decodeString $ fromMaybe today $ lookup "date" inputs Date:
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs %input!size=15!name=date!value=$string.date$
<div> ^datehelp^ $
<div id="addform"> Description:
<form action="" method="POST"> %input!size=35!name=desc!value=$string.desc$ $
<table border="0"> ^transactionfields1^
<tr> ^transactionfields2^
<td> %tr#addbuttonrow
Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %> %td
Description: <input size="35" name="desc" value=desc /><% nbsp %> %input!type=submit!value=$string.addlabel$
</td> ^addhelp^
</tr> <br clear="all" />
<% transactionfields 1 env %> |]
<% transactionfields 2 env %> where
<tr id="addbuttonrow"><td><input type="submit" value="add transaction" datehelp = helplink "dates"
/><% help "file-format" %></td></tr> addlabel = "add transaction"
</table> addhelp = helplink "file-format"
</form> action=""
</div> date = ""
<br clear="all" /> desc = ""
</div> transactionfields1 = transactionfields 1
transactionfields2 = transactionfields 2
transactionfields :: Int -> Hack.Env -> HSP XML transactionfields :: Int -> Hamlet String
transactionfields n env = do transactionfields n = [$hamlet|
let inputs = Hack.Contrib.Request.inputs env %tr
acct = decodeString $ fromMaybe "" $ lookup acctvar inputs %td
amt = decodeString $ fromMaybe "" $ lookup amtvar inputs &nbsp;&nbsp;
<tr> Account:
<td> %input!size=35!name=$string.acctvar$!value=$string.acct$
<% nbsp %><% nbsp %> &nbsp;
Account: <input size="35" name=acctvar value=acct /><% nbsp %> Amount:
Amount: <input size="15" name=amtvar value=amt /><% nbsp %> %input!size=15!name=$string.amtvar$!value=$string.amt$ $
</td> |]
</tr> where
where acct = ""
numbered = (++ show n) amt = ""
acctvar = numbered "acct" numbered = (++ show n)
amtvar = numbered "amt" acctvar = numbered "acct"
amtvar = numbered "amt"
handleAddform :: Journal -> AppUnit postTransactionsPage :: Handler HledgerWebApp RepPlain
handleAddform j = do postTransactionsPage = do
env <- getenv today <- liftIO getCurrentDay
d <- io getCurrentDay -- get form input values, or basic validation errors. E suffix means an Either value.
t <- io getCurrentLocalTime dateE <- runFormPost $ catchFormError $ notEmpty $ required $ input "date"
handle t $ validate env d descE <- runFormPost $ catchFormError $ required $ input "desc"
where acct1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct1"
validate :: Hack.Env -> Day -> Failing Transaction amt1E <- runFormPost $ catchFormError $ required $ input "amt1"
validate env today = acct2E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct2"
let inputs = Hack.Contrib.Request.inputs env amt2E <- runFormPost $ catchFormError $ required $ input "amt2"
date = decodeString $ fromMaybe "today" $ lookup "date" inputs -- supply defaults and parse date and amounts, or get errors.
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs let dateE' = either Left (either (\e -> Left [("date", showDateParseError e)]) Right . fixSmartDateStrEither today) dateE
acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs amt1E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt1E -- XXX missingamt only when missing/empty
amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs amt2E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt2E
acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs strEs = [dateE', descE, acct1E, acct2E]
amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs amtEs = [amt1E', amt2E']
validateDate "" = ["missing date"] errs = lefts strEs ++ lefts amtEs
validateDate _ = [] [date,desc,acct1,acct2] = rights strEs
validateDesc "" = ["missing description"] [amt1,amt2] = rights amtEs
validateDesc _ = [] -- if no errors so far, generate a transaction and balance it or get the error.
validateAcct1 "" = ["missing account 1"] tE | not $ null errs = Left errs
validateAcct1 _ = [] | otherwise = either (\e -> Left [[("unbalanced postings", head $ lines e)]]) Right
validateAmt1 "" = ["missing amount 1"] (balanceTransaction $ nulltransaction {
validateAmt1 _ = [] tdate=parsedate date
validateAcct2 "" = ["missing account 2"] ,teffectivedate=Nothing
validateAcct2 _ = [] ,tstatus=False
validateAmt2 _ = [] ,tcode=""
amt1' = either (const missingamt) id $ parse someamount "" amt1 ,tdescription=desc
amt2' = either (const missingamt) id $ parse someamount "" amt2 ,tcomment=""
(date', dateparseerr) = case fixSmartDateStrEither today date of ,tpostings=[
Right d -> (d, []) Posting False acct1 amt1 "" RegularPosting Nothing
Left e -> ("1900/01/01", [showDateParseError e]) ,Posting False acct2 amt2 "" RegularPosting Nothing
t = Transaction { ]
tdate = parsedate date' -- date' must be parseable ,tpreceding_comment_lines=""
,teffectivedate=Nothing })
,tstatus=False -- display errors or add transaction
,tcode="" case tE of
,tdescription=desc Left errs -> do
,tcomment="" -- save current form values in session
,tpostings=[ setMessage $ string $ intercalate ", " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) errs
Posting False acct1 amt1' "" RegularPosting (Just t') redirect RedirectTemporary TransactionsPage
,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 Right t -> do
handle _ (Failure errs) = hsp errs addform let t' = txnTieKnot t -- XXX move into balanceTransaction
handle ti (Success t) = do j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
io $ journalAddTransaction j t >> reload j j' <- liftIO $ journalAddTransaction j t' >>= journalReload
ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti)) liftIO $ putValue "hledger" "journal" j'
where msg = printf "Added transaction:\n%s" (show t) setMessage $ string $ printf "Added transaction:\n%s" (show t')
redirect RedirectTemporary TransactionsPage
-}