web: Re-add 'balanced transaction' validation to add form

hledger-web/Hledger/Web/Handler/AddR.hs

@@ -9,11 +9,13 @@ module Hledger.Web.Handler.AddR
   , postAddR
   ) where
 
+import qualified Data.Text as T
+import Text.Blaze.Html (preEscapedToHtml)
+
 import Hledger
 import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout)
 import Hledger.Web.Import
 import Hledger.Web.Widget.AddForm (addForm)
-import Hledger.Web.Widget.Common (fromFormSuccess)
 
 getAddR :: Handler ()
 getAddR = postAddR
@@ -24,12 +26,18 @@ postAddR = do
   when (CapAdd `notElem` caps) (permissionDenied "Missing the 'add' capability")
 
   ((res, view), enctype) <- runFormPost $ addForm j today
-  t <- txnTieKnot <$> fromFormSuccess (showForm view enctype) res
-  -- XXX(?) move into balanceTransaction
-  liftIO $ ensureJournalFileExists (journalFilePath j)
-  liftIO $ appendToJournalFileOrStdout (journalFilePath j) (showTransaction t)
-  setMessage "Transaction added."
-  redirect JournalR
+  case res of
+    FormSuccess res' -> do
+      let t = txnTieKnot res'
+      -- XXX(?) move into balanceTransaction
+      liftIO $ ensureJournalFileExists (journalFilePath j)
+      liftIO $ appendToJournalFileOrStdout (journalFilePath j) (showTransaction t)
+      setMessage "Transaction added."
+      redirect JournalR
+    FormMissing -> showForm view enctype
+    FormFailure errs -> do
+      mapM_ (setMessage . preEscapedToHtml . T.replace "\n" "<br>") errs
+      showForm view enctype
   where
     showForm view enctype =
       sendResponse =<< defaultLayout [whamlet|

hledger-web/Hledger/Web/Widget/AddForm.hs

@@ -21,7 +21,7 @@ import qualified Data.Text as T
 import Data.Time (Day)
 import Text.Blaze.Internal (Markup, preEscapedString)
 import Text.JSON
-import Text.Megaparsec (eof, errorBundlePretty, runParser)
+import Text.Megaparsec (bundleErrors, eof, parseErrorTextPretty, runParser)
 import Yesod
 
 import Hledger
@@ -67,13 +67,7 @@ addForm j today = identifyForm "add" $ \extra -> do
   (descRes, descView) <- mreq textField descFS Nothing
   (acctRes, _) <- mreq listField acctFS Nothing
   (amtRes, _) <- mreq listField amtFS Nothing
-
-  let (msgs', postRes) = case validatePostings <$> acctRes <*> amtRes of
-        FormSuccess (Left es) -> (es, FormFailure ["Postings validation failed"])
-        FormSuccess (Right xs) -> ([], FormSuccess xs)
-        FormMissing -> ([], FormMissing)
-        FormFailure es -> ([], FormFailure es)
-      msgs = zip [(1 :: Int)..] $ msgs' ++ replicate (4 - length msgs') ("", "", Nothing, Nothing)
+  let (postRes, displayRows) = validatePostings acctRes amtRes
 
   let descriptions = sort $ nub $ tdescription <$> jtxns j
       escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" -- #236
@@ -81,11 +75,8 @@ addForm j today = identifyForm "add" $ \extra -> do
         encode . JSArray . fmap (\a -> JSObject $ toJSObject [("value", showJSON a)])
       journals = fst <$> jfiles j
 
-  pure (makeTransaction <$> dateRes <*> descRes <*> postRes, $(widgetFile "add-form"))
+  pure (validateTransaction dateRes descRes postRes, $(widgetFile "add-form"))
   where
-    makeTransaction date desc postings =
-      nulltransaction {tdate = date, tdescription = desc, tpostings = postings}
-
     dateFS = FieldSettings "date" Nothing Nothing (Just "date")
       [("class", "form-control input-lg"), ("placeholder", "Date")]
     descFS = FieldSettings "desc" Nothing Nothing (Just "description")
@@ -103,42 +94,90 @@ addForm j today = identifyForm "add" $ \extra -> do
       , fieldEnctype = UrlEncoded
       }
 
-validatePostings :: [Text] -> [Text] -> Either [(Text, Text, Maybe Text, Maybe Text)] [Posting]
-validatePostings a b =
-  case traverse id $ (\(_, _, x) -> x) <$> postings of
-    Left _ -> Left $ foldr catPostings [] postings
-    Right [] -> Left
-      [ ("", "", Just "Missing account", Just "Missing amount")
-      , ("", "", Just "Missing account", Nothing)
-      ]
-    Right [p] -> Left
-      [ (paccount p, T.pack . showMixedAmountWithoutPrice $ pamount p, Nothing, Nothing)
-      , ("", "", Just "Missing account", Nothing)
-      ]
-    Right xs -> Right xs
+validateTransaction ::
+     FormResult Day
+  -> FormResult Text
+  -> FormResult [Posting]
+  -> FormResult Transaction
+validateTransaction dateRes descRes postingsRes =
+  case makeTransaction <$> dateRes <*> descRes <*> postingsRes of
+    FormSuccess txn -> case balanceTransaction Nothing txn of
+      Left e -> FormFailure [T.pack e]
+      Right txn' -> FormSuccess txn'
+    x -> x
   where
-    postings = unfoldr go (True, a, b)
+    makeTransaction date desc postings =
+      nulltransaction {tdate = date, tdescription = desc, tpostings = postings}
 
-    go (_, x:xs, y:ys) = Just ((x, y, zipPosting (validateAccount x) (validateAmount y)), (True, xs, ys))
-    go (True, x:y:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (True, y:xs, []))
-    go (True, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Right missingamt)), (False, xs, []))
-    go (False, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (False, xs, []))
-    go (_, [], y:ys) = Just (("", y, zipPosting (Left "Missing account") (validateAmount y)), (False, [], ys))
-    go (_, [], []) = Nothing
 
-    zipPosting = zipEither (\acc amt -> nullposting {paccount = acc, pamount = Mixed [amt]})
+-- | Parse a list of postings out of a list of accounts and a corresponding list
+-- of amounts
+validatePostings ::
+     FormResult [Text]
+  -> FormResult [Text]
+  -> (FormResult [Posting], [(Int, (Text, Text, Maybe Text, Maybe Text))])
+validatePostings acctRes amtRes = let
 
-    catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : xs
-    catPostings (t, t', Right _) xs = (t, t', Nothing, Nothing) : xs
+  -- Zip accounts and amounts, fill in missing values and drop empty rows.
+  rows :: [(Text, Text)]
+  rows = filter (/= ("", "")) $ zipDefault "" (formSuccess [] acctRes) (formSuccess [] amtRes)
 
-    errorToFormMsg = first (("Invalid value: " <>) . T.pack . errorBundlePretty)
-    validateAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip
-    validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip
+  -- Parse values and check for incomplete rows with only an account or an amount.
+  -- The boolean in unfoldr state is for special handling of 'missingamt', where
+  -- one row may have only an account and not an amount.
+  postings :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
+  postings = unfoldr go (True, rows)
+  go (True, (x, ""):y:xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (True, y:xs))
+  go (True, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Right missingamt)), (False, xs))
+  go (False, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (False, xs))
+  go (_, ("", y):xs) = Just (("", y, zipRow (Left "Missing account") (checkAmount y)), (False, xs))
+  go (_, (x, y):xs) = Just ((x, y, zipRow (checkAccount x) (checkAmount y)), (True, xs))
+  go (_, []) = Nothing
 
--- Modification of Align, from the `these` package
-zipEither :: (a -> a' -> r) -> Either e a -> Either e' a' -> Either (Maybe e, Maybe e') r
-zipEither f a b = case (a, b) of
-  (Right a', Right b') -> Right (f a' b')
-  (Left a', Right _) -> Left (Just a', Nothing)
-  (Right _, Left b') -> Left (Nothing, Just b')
-  (Left a', Left b') -> Left (Just a', Just b')
+  zipRow (Left e) (Left e') = Left (Just e, Just e')
+  zipRow (Left e) (Right _) = Left (Just e, Nothing)
+  zipRow (Right _) (Left e) = Left (Nothing, Just e)
+  zipRow (Right acct) (Right amt) = Right (nullposting {paccount = acct, pamount = Mixed [amt]})
+
+  errorToFormMsg = first (("Invalid value: " <>) . T.pack .
+                          foldl (\s a -> s <> parseErrorTextPretty a) "" .
+                          bundleErrors)
+  checkAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip
+  checkAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip
+
+  -- Add errors to forms with zero or one rows if the form is not a FormMissing
+  result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
+  result = case (acctRes, amtRes) of
+    (FormMissing, FormMissing) -> postings
+    _ -> case postings of
+      [] -> [ ("", "", Left (Just "Missing account", Just "Missing amount"))
+           , ("", "", Left (Just "Missing account", Nothing))
+           ]
+      [x] -> [x, ("", "", Left (Just "Missing account", Nothing))]
+      xs -> xs
+
+  -- Prepare rows for rendering - resolve Eithers into error messages and pad to
+  -- at least four rows
+  display' = flip fmap result $ \(acc, amt, res) -> case res of
+    Left (mAccountErr, mAmountErr) -> (acc, amt, mAccountErr, mAmountErr)
+    Right _ -> (acc, amt, Nothing, Nothing)
+  display = display' ++ replicate (4 - length display') ("", "", Nothing, Nothing)
+
+  -- And finally prepare the final FormResult [Posting]
+  formResult = case traverse (\(_, _, x) -> x) result of
+    Left _ -> FormFailure ["Postings validation failed"]
+    Right xs -> FormSuccess xs
+
+  in (formResult, zip [(1 :: Int)..] display)
+
+
+zipDefault :: a -> [a] -> [a] -> [(a, a)]
+zipDefault def (b:bs) (c:cs) = (b, c):(zipDefault def bs cs)
+zipDefault def (b:bs) [] = (b, def):(zipDefault def bs [])
+zipDefault def [] (c:cs) = (def, c):(zipDefault def [] cs)
+zipDefault _ _ _ = []
+
+formSuccess :: a -> FormResult a -> a
+formSuccess def res = case res of
+  FormSuccess x -> x
+  _ -> def

hledger-web/templates/add-form.hamlet

@@ -40,7 +40,7 @@
     <div .col-md-9 .col-xs-6 .col-sm-6>
 
 <div .account-postings>
-  $forall (n, (acc, amt, accE, amtE)) <- msgs
+  $forall (n, (acc, amt, accE, amtE)) <- displayRows
     <div .form-group .row .account-group>
       <div .col-md-8 .col-xs-8 .col-sm-8 :isJust accE:.has-error>
         <input .account-input.form-control.input-lg.typeahead type=text