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,44 +23,70 @@ 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
+  let showErrors errs = do
-  mjournalpath <- lookupPostParam  "journal"
+        -- error $ show errs -- XXX uncomment to prevent redirect, for debugging
-  mdate <- lookupPostParam  "date"
+        setMessage [shamlet|
-  mdesc <- lookupPostParam  "description"
+                     Error:<br>
-  let edate = maybe (Left "date required") (either (\e -> Left $ showDateParseError e) Right . fixSmartDateStrEither today . strip . unpack) mdate
+                     $forall e<-errs
-      edesc = Right $ maybe "" unpack mdesc
+                      \#{e}<br>
-      ejournalpath = maybe
+                   |]
-                       (Right $ journalFilePath j)
+  formresult <- runInputPostResult $ AddForm
-                       (\f -> let f' = unpack f in
+    <$> iopt textField "journal"
-                              if f' `elem` journalFilePaths j
+    <*> iopt textField "date"
-                              then Right f'
+        -- (jqueryDayField def
-                              else Left $ "unrecognised journal file path: " ++ f'
+        -- {
-                              )
+        --   jdsChangeYear = True     -- give a year dropdown
-                       mjournalpath
+        -- , jdsYearRange = "1900:-5" -- 1900 till five years ago
-      estrs = [edate, edesc, ejournalpath]
+        -- }) "date"
-      (errs1, [date, desc, journalpath]) = case (lefts estrs, rights estrs) of
+    <*> iopt textField "description"
-        ([], [_,_,_]) -> ([], rights estrs)
+  case formresult of
-        _             -> (lefts estrs, [error "",error "",error ""]) -- RHS won't be used
+    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
-  -- mtrace params
+      let numberedParams s =
-  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
                     ]
+            where paramnamep s = do {string s; n <- many1 digit; eof; return (read n :: Int)}
           acctparams = numberedParams "account"
           amtparams  = numberedParams "amount"
           num = length acctparams
-      paramErrs | map fst acctparams == [1..num] &&
+          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 = ["malformed account/amount parameters"]
+                    | 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)
@@ -64,29 +94,21 @@ postAddForm = do
           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)
+          errs = 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
+             | otherwise = either (\e -> Left [L.head $ lines e]) Right
                             (balanceTransaction Nothing $ nulltransaction {
-                            tdate=parsedate date
+                                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' -> do
+       Left errs -> showErrors errs
-    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
+        liftIO $ do ensureJournalFileExists journalfile
-                appendToJournalFileOrStdout journalpath $ showTransaction t'
+                    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: