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,113 +44,88 @@ 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
-    -- helpers used in add-form.hamlet
+    fileField' = selectFieldList [(T.pack f, f) | f <- fs] & check validateFilepath
-    toBloodhoundJson :: [Text] -> Markup
-    toBloodhoundJson ts =
-      -- This used to work, but since 1.16, it seems like something changed.
-      -- toJSON ("a"::Text) gives String "a" instead of "a", etc.
-      -- preEscapedString . escapeJSSpecialChars . show . toJSON
-
-      preEscapedText $ T.concat [
-        "[",
-        T.intercalate "," $ map (
-          ("{\"value\":" <>).
-          (<> "}").
-          -- This will convert a value such as ``hledger!`` into
-          -- ``atob("aGxlZGdlciE=")``. When this gets evaluated on the client,
-          -- the resulting string is ``hledger!`` again. The same data is
-          -- passed, but the user-controlled bit of that string can only use
-          -- characters [a-zA-Z0-9+=/], making it impossible to break out of
-          -- string context.
-          b64wrap
-          ) ts,
-        "]"
-        ]
       where
-        b64wrap = ("atob(\""<>) . (<>"\")") . encodeBase64
+        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")]
 
 validateTransaction ::
-     FormResult Day
+     FormResult Day -> FormResult Text -> FormResult [Posting] -> FormResult FilePath
-  -> FormResult Text
+  -> FormResult (Transaction, FilePath)
-  -> FormResult [Posting]
+validateTransaction dateRes descRes postingsRes fileRes =
-  -> FormResult Transaction
+  case makeTransaction <$> dateRes <*> descRes <*> postingsRes <*> fileRes of
-validateTransaction dateRes descRes postingsRes =
+    FormSuccess (txn,f) -> case balanceTransaction defbalancingopts txn of
-  case makeTransaction <$> dateRes <*> descRes <*> postingsRes of
+      Left e     -> FormFailure [T.pack e]
-    FormSuccess txn -> case balanceTransaction defbalancingopts txn of
+      Right txn' -> FormSuccess (txn',f)
-      Left e -> FormFailure [T.pack e]
-      Right txn' -> FormSuccess txn'
     x -> x
   where
-    makeTransaction date desc postings =
+    makeTransaction date desc postings f =
-      nulltransaction {
+      (nulltransaction {
-         tdate        = date
+         tdate = date
         ,tdescription = desc
-        ,tpostings    = postings
+        ,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 [Text]
-  -> FormResult [Text]
   -> (FormResult [Posting], [(Int, (Text, Text, Maybe Text, Maybe Text))])
-validatePostings acctRes amtRes = let
+validatePostings acctsRes amtsRes = let
 
   -- Zip accounts and amounts, fill in missing values and drop empty rows.
   rows :: [(Text, Text)]
-  rows = filter (/= ("", "")) $ zipDefault "" (formSuccess [] acctRes) (formSuccess [] amtRes)
+  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)
-  go (True, (x, ""):y:xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (True, y:xs))
+    where
-  go (True, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Right missingamt)), (False, xs))
+      go (True, (x, ""):y:xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (True, y:xs))
-  go (False, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (False, xs))
+      go (True, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Right missingamt)), (False, xs))
-  go (_, ("", y):xs) = Just (("", y, zipRow (Left "Missing account") (checkAmount y)), (False, xs))
+      go (False, (x, ""):xs) = Just ((x, "", zipRow (checkAccount x) (Left "Missing amount")), (False, xs))
-  go (_, (x, y):xs) = Just ((x, y, zipRow (checkAccount x) (checkAmount y)), (True, xs))
+      go (_, ("", y):xs) = Just (("", y, zipRow (Left "Missing account") (checkAmount y)), (False, xs))
-  go (_, []) = Nothing
+      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)
@@ -174,7 +143,7 @@ validatePostings acctRes amtRes = let
 
   -- 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
+  result = case (acctsRes, amtsRes) of
     (FormMissing, FormMissing) -> postings
     _ -> case postings of
       [] -> [ ("", "", Left (Just "Missing account", Just "Missing amount"))
@@ -196,6 +165,30 @@ validatePostings acctRes amtRes = let
 
   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.
+  -- toJSON ("a"::Text) gives String "a" instead of "a", etc.
+  -- preEscapedString . escapeJSSpecialChars . show . toJSON
+
+  preEscapedText $ T.concat [
+    "[",
+    T.intercalate "," $ map (
+      ("{\"value\":" <>).
+      (<> "}").
+      -- This will convert a value such as ``hledger!`` into
+      -- ``atob("aGxlZGdlciE=")``. When this gets evaluated on the client,
+      -- the resulting string is ``hledger!`` again. The same data is
+      -- passed, but the user-controlled bit of that string can only use
+      -- characters [a-zA-Z0-9+=/], making it impossible to break out of
+      -- string context.
+      b64wrap
+      ) ts,
+    "]"
+    ]
+  where
+    b64wrap = ("atob(\""<>) . (<>"\")") . encodeBase64
 
 zipDefault :: a -> [a] -> [a] -> [(a, a)]
 zipDefault def (b:bs) (c:cs) = (b, c):(zipDefault def bs cs)

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;">