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

web: improve add form validation (#223, #234)

Browse Source 
The add form is now partly using yesod-form.
This commit is contained in:
Simon Michael 2015-02-16 18:22:17 +00:00
parent 16aaf35c4b
commit d3453c66c1
2 changed files with 92 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

158
hledger-web/Handler/AddForm.hs
View File

@ -1,4 +1,6 @@
-- | POST helpers.
-- | Add form data & handler. (The layout and js are defined in
-- Foundation so that the add form can be in the default layout for
-- all views.)
module Handler.AddForm where
@ -8,10 +10,12 @@ import Control.Applicative
import Data.Either (lefts,rights)
import Data.List (sort)
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
-- import Data.Maybe
import Data.Text (unpack)
import qualified Data.Text as T
import Data.Time.Calendar
-- import Data.Time.Calendar
import Text.Parsec (digit, eof, many1, string, runParser)
-- import Yesod.Form.Jquery
import Hledger.Utils
import Hledger.Data hiding (num)
@ -19,74 +23,92 @@ import Hledger.Read
import Hledger.Cli hiding (num)
-- | Handle a post from the transaction add form.
-- Part of the data required from the add form.
-- Don't know how to handle the variable posting fields with yesod-form yet.
data AddForm = AddForm
{ addFormJournalFile :: Maybe Text -- FilePath
, addFormDate :: Maybe Text -- Day
, addFormDescription :: Maybe Text -- String
-- , addFormPostings :: [(AccountName, String)]
}
deriving Show
postAddForm :: Handler Html
postAddForm = do
VD{..} <- getViewData
-- XXX gruesome form handling, port to yesod-form. cf #234
mjournalpath <- lookupPostParam "journal"
mdate <- lookupPostParam "date"
mdesc <- lookupPostParam "description"
let edate = maybe (Left "date required") (either (\e -> Left $ showDateParseError e) Right . fixSmartDateStrEither today . strip . unpack) mdate
edesc = Right $ maybe "" unpack mdesc
ejournalpath = maybe
(Right $ journalFilePath j)
(\f -> let f' = unpack f in
if f' `elem` journalFilePaths j
then Right f'
else Left $ "unrecognised journal file path: " ++ f'
)
mjournalpath
estrs = [edate, edesc, ejournalpath]
(errs1, [date, desc, journalpath]) = case (lefts estrs, rights estrs) of
([], [_,_,_]) -> ([], rights estrs)
_ -> (lefts estrs, [error "",error "",error ""]) -- RHS won't be used
(params,_) <- runRequestBody
-- mtrace params
let paramnamep s = do {string s; n <- many1 digit; eof; return (read n :: Int)}
numberedParams s =
reverse $ dropWhile (T.null . snd) $ reverse $ sort
[ (n,v) | (k,v) <- params
, let en = parsewith (paramnamep s) $ T.unpack k
, isRight en
, let Right n = en
]
acctparams = numberedParams "account"
amtparams = numberedParams "amount"
num = length acctparams
paramErrs | map fst acctparams == [1..num] &&
map fst amtparams `elem` [[1..num], [1..num-1]] = []
| otherwise = ["malformed account/amount parameters"]
eaccts = map (parsewith (accountnamep <* eof) . strip . T.unpack . snd) acctparams
eamts = map (runParser (amountp <* eof) nullctx "" . strip . T.unpack . snd) amtparams
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
(amts', amtErrs) = (rights eamts, map show $ lefts eamts)
amts | length amts' == num = amts'
| otherwise = amts' ++ [missingamt]
-- if no errors so far, generate a transaction and balance it or get the error.
errs = errs1 ++ if not (null paramErrs) then paramErrs else (acctErrs ++ amtErrs)
et | not $ null errs = Left errs
| otherwise = either (\e -> Left ["unbalanced postings: " ++ (L.head $ lines e)]) Right
(balanceTransaction Nothing $ nulltransaction {
tdate=parsedate date
,tdescription=desc
,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts]
})
-- display errors or add transaction
case et of
Left errs' -> do
error $ show errs' -- XXX
-- save current form values in session
-- setMessage $ toHtml $ intercalate "; " errs
setMessage [shamlet|
Errors:<br>
$forall e<-errs'
\#{e}<br>
|]
Right t -> do
let t' = txnTieKnot t -- XXX move into balanceTransaction
liftIO $ do ensureJournalFileExists journalpath
appendToJournalFileOrStdout journalpath $ showTransaction t'
setMessage [shamlet|<span>Transaction added.|]
let showErrors errs = do
-- error $ show errs -- XXX uncomment to prevent redirect, for debugging
setMessage [shamlet|
Error:<br>
$forall e<-errs
\#{e}<br>
|]
formresult <- runInputPostResult $ AddForm
<$> iopt textField "journal"
<*> iopt textField "date"
-- (jqueryDayField def
-- {
-- jdsChangeYear = True -- give a year dropdown
-- , jdsYearRange = "1900:-5" -- 1900 till five years ago
-- }) "date"
<*> iopt textField "description"
case formresult of
FormMissing -> showErrors ["there is no form data"::String]
FormFailure errs -> showErrors errs
FormSuccess formdata -> do
let AddForm{
addFormJournalFile=mjournalfile
,addFormDate =mdate
,addFormDescription=mdesc
} = formdata
date = parsedate $ fixSmartDateStr today $ maybe "today" (strip . unpack) mdate
desc = maybe "" unpack mdesc
journalfile = maybe
(journalFilePath j)
(\f' -> let f = unpack f' in
if f `elem` journalFilePaths j
then f
else error $ "the selected journal file is unknown: " ++ f)
mjournalfile
(params,_) <- runRequestBody
let numberedParams s =
reverse $ dropWhile (T.null . snd) $ reverse $ sort
[ (n,v) | (k,v) <- params
, let en = parsewith (paramnamep s) $ T.unpack k
, isRight en
, let Right n = en
]
where paramnamep s = do {string s; n <- many1 digit; eof; return (read n :: Int)}
acctparams = numberedParams "account"
amtparams = numberedParams "amount"
num = length acctparams
paramErrs | num == 0 = ["at least one posting must be entered"]
| map fst acctparams == [1..num] &&
map fst amtparams `elem` [[1..num], [1..num-1]] = []
| otherwise = ["the posting parameters are malformed"]
eaccts = map (parsewith (accountnamep <* eof) . strip . T.unpack . snd) acctparams
eamts = map (runParser (amountp <* eof) nullctx "" . strip . T.unpack . snd) amtparams
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
(amts', amtErrs) = (rights eamts, map show $ lefts eamts)
amts | length amts' == num = amts'
| otherwise = amts' ++ [missingamt]
-- if no errors so far, generate a transaction and balance it or get the error.
errs = if not (null paramErrs) then paramErrs else (acctErrs ++ amtErrs)
et | not $ null errs = Left errs
| otherwise = either (\e -> Left [L.head $ lines e]) Right
(balanceTransaction Nothing $ nulltransaction {
tdate=date
,tdescription=desc
,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts]
})
-- display errors or add transaction
case et of
Left errs -> showErrors errs
Right t -> do
let t' = txnTieKnot t -- XXX move into balanceTransaction
liftIO $ do ensureJournalFileExists journalfile
appendToJournalFileOrStdout journalfile $ showTransaction t'
setMessage [shamlet|<span>Transaction added.|]
redirect (JournalR) -- , [("add","1")])

2
hledger-web/hledger-web.cabal
View File

@ -187,6 +187,7 @@ library
, yaml
, yesod >= 1.4 && < 1.5
, yesod-core
, yesod-form
, yesod-static
, json
-- required by extra ghci utilities:
@ -258,6 +259,7 @@ executable hledger-web
, yaml
, yesod >= 1.4 && < 1.5
, yesod-core
, yesod-form
, yesod-static
, json
-- required by extra ghci utilities: