diff --git a/hledger-web/Handler/AddForm.hs b/hledger-web/Handler/AddForm.hs index cff0c8679..add2ec9c9 100644 --- a/hledger-web/Handler/AddForm.hs +++ b/hledger-web/Handler/AddForm.hs @@ -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:
- $forall e<-errs' - \#{e}
- |] - Right t -> do - let t' = txnTieKnot t -- XXX move into balanceTransaction - liftIO $ do ensureJournalFileExists journalpath - appendToJournalFileOrStdout journalpath $ showTransaction t' - setMessage [shamlet|Transaction added.|] + let showErrors errs = do + -- error $ show errs -- XXX uncomment to prevent redirect, for debugging + setMessage [shamlet| + Error:
+ $forall e<-errs + \#{e}
+ |] + 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|Transaction added.|] redirect (JournalR) -- , [("add","1")]) diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 0e804ac0b..292b532f9 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -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: