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

The add form is now partly using yesod-form.

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:<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")])

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: