web: edit/upload: normalise line endings, avoiding parse errors (#1194)

Renamed: writeValidJournal -> writeJournalTextIfValidAndChanged

Added comments clarifying line ending behaviour of:
add, import, appendToJournalFileOrStdout, readFilePortably,
writeFileWithBackupIfChanged, writeJournalTextIfValidAndChanged

Summary of current behaviour:

- hledger add and import commands will append with (at least some)
  unix line endings, possibly causing the file to have mixed line
  endings

- hledger-web edit and upload forms will write the file with
  the current system's native line endings, ie changing all
  line endings if the file previously used foreign line endings.

hledger-lib/Hledger/Read.hs

@@ -215,6 +215,7 @@ readJournalFile iopts prefixedfile = do
     iopts' = iopts{mformat_=firstJust [mfmt, mformat_ iopts]}
   requireJournalFileExists f
   t <- readFileOrStdinPortably f
+    -- <- T.readFile f  -- or without line ending translation, for testing
   ej <- readJournal iopts' (Just f) t
   case ej of
     Left e  -> return $ Left e

hledger-lib/Hledger/Read/Common.hs

@@ -1053,7 +1053,7 @@ followingcommentp' contentp = do
 --
 followingcommentp :: TextParser m Text
 followingcommentp =
-  fst <$> followingcommentp' (void $ takeWhileP Nothing (/= '\n'))
+  fst <$> followingcommentp' (void $ takeWhileP Nothing (/= '\n'))  -- XXX support \r\n ?
 {-# INLINABLE followingcommentp #-}
 
 

hledger-lib/Hledger/Utils.hs

@@ -183,7 +183,7 @@ firstJust ms = case dropWhile (==Nothing) ms of
     (md:_) -> md
 
 -- | Read text from a file,
--- handling any of the usual line ending conventions,
+-- converting any \r\n line endings to \n,,
 -- using the system locale's text encoding,
 -- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.
 readFilePortably :: FilePath -> IO Text

hledger-lib/Hledger/Utils/Parse.hs

@@ -120,6 +120,8 @@ nonspace = satisfy (not . isSpace)
 
 isNonNewlineSpace :: Char -> Bool
 isNonNewlineSpace c = c /= '\n' && isSpace c
+-- XXX support \r\n ?
+-- isNonNewlineSpace c = c /= '\n' && c /= '\r' && isSpace c
 
 spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char
 spacenonewline = satisfy isNonNewlineSpace

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

@@ -12,7 +12,7 @@ module Hledger.Web.Handler.EditR
 
 import Hledger.Web.Import
 import Hledger.Web.Widget.Common
-       (fromFormSuccess, helplink, journalFile404, writeValidJournal)
+       (fromFormSuccess, helplink, journalFile404, writeJournalTextIfValidAndChanged)
 
 editForm :: FilePath -> Text -> Markup -> MForm Handler (FormResult Text, Widget)
 editForm f txt =
@@ -35,8 +35,8 @@ postEditR f = do
 
   (f', txt) <- journalFile404 f j
   ((res, view), enctype) <- runFormPost (editForm f' txt)
-  text <- fromFormSuccess (showForm view enctype) res
+  newtxt <- fromFormSuccess (showForm view enctype) res
-  writeValidJournal f text >>= \case
+  writeJournalTextIfValidAndChanged f newtxt >>= \case
     Left e -> do
       setMessage $ "Failed to load journal: " <> toHtml e
       showForm view enctype

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

@@ -15,7 +15,7 @@ import Data.Conduit.Binary (sinkLbs)
 import qualified Data.Text.Encoding as TE
 
 import Hledger.Web.Import
-import Hledger.Web.Widget.Common (fromFormSuccess, journalFile404, writeValidJournal)
+import Hledger.Web.Widget.Common (fromFormSuccess, journalFile404, writeJournalTextIfValidAndChanged)
 
 uploadForm :: FilePath -> Markup -> MForm Handler (FormResult FileInfo, Widget)
 uploadForm f =
@@ -44,15 +44,15 @@ postUploadR f = do
 
   -- Try to parse as UTF-8
   -- XXX Unfortunate - how to parse as system locale?
-  text <- case TE.decodeUtf8' lbs of
+  newtxt <- case TE.decodeUtf8' lbs of
     Left e -> do
       setMessage $
         "Encoding error: '" <> toHtml (show e) <> "'. " <>
         "If your file is not UTF-8 encoded, try the 'edit form', " <>
         "where the transcoding should be handled by the browser."
       showForm view enctype
-    Right text -> return text
+    Right newtxt -> return newtxt
-  writeValidJournal f text >>= \case
+  writeJournalTextIfValidAndChanged f newtxt >>= \case
     Left e -> do
       setMessage $ "Failed to load journal: " <> toHtml e
       showForm view enctype

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

@@ -12,7 +12,7 @@ module Hledger.Web.Widget.Common
   , helplink
   , mixedAmountAsHtml
   , fromFormSuccess
-  , writeValidJournal
+  , writeJournalTextIfValidAndChanged
   , journalFile404
   ) where
 
@@ -50,15 +50,29 @@ fromFormSuccess h FormMissing = h
 fromFormSuccess h (FormFailure _) = h
 fromFormSuccess _ (FormSuccess a) = pure a
 
-writeValidJournal :: MonadHandler m => FilePath -> Text -> m (Either String ())
+-- | A helper for postEditR/postUploadR: check that the given text
-writeValidJournal f txt =
+-- parses as a Journal, and if so, write it to the given file, if the
-  liftIO (readJournal def (Just f) txt) >>= \case
+-- text has changed. Or, return any error message encountered.
+--
+-- As a convenience for data received from web forms, which does not
+-- have normalised line endings, line endings will be normalised (to \n)
+-- before parsing.
+--
+-- The file will be written (if changed) with the current system's native
+-- line endings (see writeFileWithBackupIfChanged).
+--
+writeJournalTextIfValidAndChanged :: MonadHandler m => FilePath -> Text -> m (Either String ())
+writeJournalTextIfValidAndChanged f t = do
+  -- Ensure unix line endings, since both readJournal (cf
+  -- formatdirectivep, #1194) writeFileWithBackupIfChanged require them.
+  -- XXX klunky. Any equivalent of "hSetNewlineMode h universalNewlineMode" for form posts ?
+  let t' = T.pack $ regexReplace "\r" "" $ T.unpack t
+  liftIO (readJournal def (Just f) t') >>= \case
     Left e -> return (Left e)
     Right _ -> do
-      _ <- liftIO (writeFileWithBackupIfChanged f txt)
+      _ <- liftIO (writeFileWithBackupIfChanged f t')
       return (Right ())
 
-
 -- | Link to a topic in the manual.
 helplink :: Text -> Text -> HtmlUrl r
 helplink topic label _ = H.a ! A.href u ! A.target "hledgerhelp" $ toHtml label

hledger/Hledger/Cli/Commands/Add.hs

@@ -443,6 +443,11 @@ journalAddTransaction j@Journal{jtxns=ts} opts t = do
 -- | Append a string, typically one or more transactions, to a journal
 -- file, or if the file is "-", dump it to stdout.  Tries to avoid
 -- excess whitespace.
+--
+-- XXX This writes unix line endings (\n), some at least,
+-- even if the file uses dos line endings (\r\n), which could leave
+-- mixed line endings in the file. See also writeFileWithBackupIfChanged.
+--
 appendToJournalFileOrStdout :: FilePath -> String -> IO ()
 appendToJournalFileOrStdout f s
   | f == "-"  = putStr s'

hledger/Hledger/Cli/Commands/Import.hs

@@ -54,5 +54,8 @@ importcmd opts@CliOpts{rawopts_=rawopts,inputopts_=iopts} j = do
             newts | catchup -> do
               printf "marked %s as caught up, skipping %d unimported transactions\n\n" inputstr (length newts)
             newts -> do
+              -- XXX This writes unix line endings (\n), some at least,
+              -- even if the file uses dos line endings (\r\n), which could leave
+              -- mixed line endings in the file. See also writeFileWithBackupIfChanged.
               foldM_ (`journalAddTransaction` opts) j newts  -- gets forced somehow.. (how ?)
               printf "imported %d new transactions from %s\n" (length newts) inputstr

hledger/Hledger/Cli/Utils.hs

@@ -230,6 +230,14 @@ openBrowserOn u = trybrowsers browsers u
 -- overwrite it with this new text, or give an error, but only if the text
 -- is different from the current file contents, and return a flag
 -- indicating whether we did anything.
+--
+-- The given text should have unix line endings (\n); the existing
+-- file content will be normalised to unix line endings before
+-- comparing the two. If the file is overwritten, the new file will
+-- have the current system's native line endings (\n on unix, \r\n on
+-- windows). This could be different from the file's previous line
+-- endings, if working with a DOS file on unix or vice-versa.
+--
 writeFileWithBackupIfChanged :: FilePath -> T.Text -> IO Bool
 writeFileWithBackupIfChanged f t = do
   s <- readFilePortably f