fix: web: add form: re-enable the file field (#1229)

It was ignored since cc1241fa2 in 2018. Also simplify some types.

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

@@ -35,12 +35,11 @@ postAddR = do
 
   ((res, view), enctype) <- runFormPost $ addForm j today
   case res of
-    FormSuccess res' -> do
+    FormSuccess (t,f) -> do
-      let t = txnTieKnot res'
+      let t' = txnTieKnot t
-      -- XXX(?) move into balanceTransaction
+      liftIO $ do
-      liftIO $ ensureJournalFileExists (journalFilePath j)
+        ensureJournalFileExists f
-      -- XXX why not journalAddTransaction ?
+        appendToJournalFileOrStdout f (showTransaction t')
-      liftIO $ appendToJournalFileOrStdout (journalFilePath j) (showTransaction t)
       setMessage "Transaction added."
       redirect JournalR
     FormMissing -> showForm view enctype

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

@@ -25,19 +25,13 @@ import Text.Megaparsec (bundleErrors, eof, parseErrorTextPretty, runParser)
 import Yesod
 
 import Hledger
-import Hledger.Web.Foundation -- (App, Form, Handler, Widget)
+import Hledger.Web.Foundation (App, Handler, Widget)
 import Hledger.Web.Settings (widgetFile)
+import Data.Function ((&))
 
--- addModal ::
---      ( MonadWidget m
---      , r ~ Route (HandlerSite m)
---      , m ~ WidgetFor (HandlerSite m)
---      , RenderMessage (HandlerSite m) FormMessage
---      )
---   => r -> Journal -> Day -> m ()
 addModal :: Route App -> Journal -> Day -> Widget
 addModal addR j today = do
-  (addView, addEnctype) <- generateFormPost (addForm j today)
+  (addView, addEnctype) <- handlerToWidget $ generateFormPost (addForm j today)
   [whamlet|
 <div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true">
   <div .modal-dialog .modal-lg>
@@ -50,47 +44,128 @@ addModal addR j today = do
           ^{addView}
 |]
 
--- addForm ::
+addForm :: Journal -> Day -> Markup -> MForm Handler (FormResult (Transaction,FilePath), Widget)
---      (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m)
---   => Journal
---   -> Day
---   -> Markup
---   -> MForm m (FormResult Transaction, WidgetFor site ())
-addForm ::
-  (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => 
-  Journal -> Day -> Markup ->
-  MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ())
 addForm j today = identifyForm "add" $ \extra -> do
   let  -- bindings used in add-form.hamlet
     descriptions = foldMap S.fromList [journalPayeesDeclaredOrUsed j, journalDescriptions j]
     files = fst <$> jfiles j
   (dateRes, dateView) <- mreq dateField dateSettings Nothing
   (descRes, descView) <- mreq textField descSettings Nothing
-  (acctRes, _)        <- mreq listField "account" Nothing
+  (acctsRes, _)       <- mreq listField acctSettings Nothing
-  (amtRes , _)        <- mreq listField "amount" Nothing
+  (amtsRes, _)        <- mreq listField amtSettings  Nothing
-  let (postRes, displayRows) = validatePostings acctRes amtRes
+  (fileRes, fileView) <- mreq fileField' fileSettings Nothing
-  pure (validateTransaction dateRes descRes postRes, $(widgetFile "add-form"))
+  let
-
+    (postingsRes, displayRows) = validatePostings acctsRes amtsRes
+    formRes = validateTransaction dateRes descRes postingsRes fileRes
+  return (formRes, $(widgetFile "add-form"))
   where
-    -- field settings
+    -- custom fields
-    dateSettings = FieldSettings "date" Nothing Nothing (Just "date")
+    dateField = textField & checkMMap (pure . validateDate) (T.pack . show)
-      [("class", "form-control input-lg"), ("placeholder", "Date")]
-    descSettings = FieldSettings "desc" Nothing Nothing (Just "description")
-      [("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")]
-
-    -- custom field types
-    dateField = checkMMap (pure . validateDate) (T.pack . show) textField
       where
         validateDate s =
           first (const ("Invalid date format" :: Text)) $
           fixSmartDateStrEither' today (T.strip s)
     listField = Field
       { fieldParse = const . pure . Right . Just . dropWhileEnd T.null
-      , fieldView = error "Don't render using this!"  -- PARTIAL:
+      , fieldView = error' "listField should not be used for rendering"  -- PARTIAL:
       , fieldEnctype = UrlEncoded
       }
+    fileField' :: Field Handler FilePath
+    fileField' = selectFieldList [(T.pack f, f) | f <- fs] & check validateFilepath
+      where
+        fs = journalFilePaths j
+        validateFilepath :: FilePath -> Either FormMessage FilePath
+        validateFilepath f
+          | f `elem` fs = Right f
+          | otherwise = Left $ MsgInputNotFound $ T.pack f
+    -- field settings
+    dateSettings = FieldSettings "date" Nothing Nothing (Just "date") [("class", "form-control input-lg"), ("placeholder", "Date")]
+    descSettings = FieldSettings "desc" Nothing Nothing (Just "description") [("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")]
+    acctSettings = FieldSettings "account" Nothing Nothing (Just "account") []
+    amtSettings  = FieldSettings "amount" Nothing Nothing (Just "amount") []
+    fileSettings = FieldSettings "file" Nothing Nothing (Just "file") [("class", "form-control input-lg")]
 
-    -- helpers used in add-form.hamlet
+validateTransaction ::
+     FormResult Day -> FormResult Text -> FormResult [Posting] -> FormResult FilePath
+  -> FormResult (Transaction, FilePath)
+validateTransaction dateRes descRes postingsRes fileRes =
+  case makeTransaction <$> dateRes <*> descRes <*> postingsRes <*> fileRes of
+    FormSuccess (txn,f) -> case balanceTransaction defbalancingopts txn of
+      Left e     -> FormFailure [T.pack e]
+      Right txn' -> FormSuccess (txn',f)
+    x -> x
+  where
+    makeTransaction date desc postings f =
+      (nulltransaction {
+         tdate = date
+        ,tdescription = desc
+        ,tpostings = postings
+        ,tsourcepos = (initialPos f, initialPos f)
+        }, f)
+
+-- | 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 acctsRes amtsRes = let
+
+  -- Zip accounts and amounts, fill in missing values and drop empty rows.
+  rows :: [(Text, Text)]
+  rows = filter (/= ("", "")) $ zipDefault "" (formSuccess [] acctsRes) (formSuccess [] amtsRes)
+
+  -- 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)
+    where
+      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
+
+  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, ptype = atype, pamount = mixedAmount amt})
+    where
+      acct = accountNameWithoutPostingType acct'
+      atype = accountNamePostingType acct'
+
+  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) nulljournal) "" . T.strip
+
+  -- Add errors to forms with zero rows if the form is not a FormMissing
+  result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
+  result = case (acctsRes, amtsRes) of
+    (FormMissing, FormMissing) -> postings
+    _ -> case postings of
+      [] -> [ ("", "", Left (Just "Missing account", Just "Missing amount"))
+           , ("", "", 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)
+
+-- helper for add-form.hamlet
 toBloodhoundJson :: [Text] -> Markup
 toBloodhoundJson ts =
   -- This used to work, but since 1.16, it seems like something changed.
@@ -115,88 +190,6 @@ addForm j today = identifyForm "add" $ \extra -> do
   where
     b64wrap = ("atob(\""<>) . (<>"\")") . encodeBase64
 
-validateTransaction ::
-     FormResult Day
-  -> FormResult Text
-  -> FormResult [Posting]
-  -> FormResult Transaction
-validateTransaction dateRes descRes postingsRes =
-  case makeTransaction <$> dateRes <*> descRes <*> postingsRes of
-    FormSuccess txn -> case balanceTransaction defbalancingopts txn of
-      Left e -> FormFailure [T.pack e]
-      Right txn' -> FormSuccess txn'
-    x -> x
-  where
-    makeTransaction date desc postings =
-      nulltransaction {
-         tdate        = date
-        ,tdescription = desc
-        ,tpostings    = postings
-        }
-
--- | 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
-
-  -- Zip accounts and amounts, fill in missing values and drop empty rows.
-  rows :: [(Text, Text)]
-  rows = filter (/= ("", "")) $ zipDefault "" (formSuccess [] acctRes) (formSuccess [] amtRes)
-
-  -- 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
-
-  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, ptype = atype, pamount = mixedAmount amt})
-    where
-      acct = accountNameWithoutPostingType acct'
-      atype = accountNamePostingType acct'
-
-  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) nulljournal) "" . T.strip
-
-  -- Add errors to forms with zero 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))
-           ]
-      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 [])

hledger-web/templates/add-form.hamlet

@@ -60,8 +60,7 @@
 
 $if length files > 1
   <br>
-  <span .input-lg>to:
+  <div style="display:inline-block; width:auto;" .form-group :isJust (fvErrors fileView):.has-error>
-    <select #journalselect .form-control.input-lg name=file style="width:auto; display:inline-block;">
+    To file: ^{fvInput fileView}
-      $forall f <- files
+    $maybe err <- fvErrors fileView
-        <option value=#{f}>#{f}
+      <span .help-block .error-block>#{err}
-<span .small style="padding-left:2em;">