webyesod: validate the journal before accepting an edit

Hledger/Cli/Commands/Web.hs

@@ -21,6 +21,7 @@ import Hledger.Cli.Commands.Register
 import Hledger.Cli.Options hiding (value)
 import Hledger.Cli.Utils
 import Hledger.Data
+import Hledger.Read (journalFromPathAndString)
 import Hledger.Read.Journal (someamount)
 #ifdef MAKE
 import Paths_hledger_make (getDataFileName)
@@ -117,8 +118,8 @@ withLatestJournalRender reportfn = do
         fspec = optsToFilterSpec opts args t
     -- reload journal if changed, displaying any error as a message
     j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
-    (changed, jE) <- liftIO $ journalReloadIfChanged opts j
-    (err, j') <- either (\e -> return (show e,j)) (\j -> return ("",j)) jE
+    (jE, changed) <- liftIO $ journalReloadIfChanged opts j
+    let (j', err) = either (\e -> (j,e)) (\j -> (j,"")) jE
     when (changed && null err) $ liftIO $ putValue "hledger" "journal" j'
     if (changed && not (null err)) then setMessage $ string "error while reading"
                                  else return ()
@@ -333,8 +334,6 @@ postJournalPage = do
    Right t -> do
     let t' = txnTieKnot t -- XXX move into balanceTransaction
     j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
-    -- j' <- liftIO $ journalAddTransaction j t' >>= journalReload
-    -- liftIO $ putValue "hledger" "journal" j'
     liftIO $ journalAddTransaction j t'
     setMessage $ string $ printf "Added transaction:\n%s" (show t')
     redirect RedirectTemporary JournalPage
@@ -412,11 +411,12 @@ postEditPage = do
   -- display errors or add transaction
   case textE of
    Left errs -> do
-    -- save current form values in session
+    -- XXX should save current form values in session
     setMessage $ string $ intercalate "; " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) [errs]
     redirect RedirectTemporary JournalPage
 
    Right t' -> do
+    -- try to avoid unnecessary backups or saving invalid data
     j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
     filechanged' <- liftIO $ journalFileIsNewer j
     let f = filepath j
@@ -424,8 +424,19 @@ postEditPage = do
         tnew = filter (/= '\r') t'
         changed = tnew /= told || filechanged'
 --    changed <- liftIO $ writeFileWithBackupIfChanged f t''
+    if not changed
+     then do
+       setMessage $ string $ "No change"
+       redirect RedirectTemporary EditPage
+     else do
+      jE <- liftIO $ journalFromPathAndString Nothing f tnew
+      either
+       (\e -> do
+          setMessage $ string e
+          redirect RedirectTemporary EditPage)
+       (const $ do
           liftIO $ writeFileWithBackup f tnew
-    setMessage $ string $ if changed then printf "Saved journal to %s\n" (show f)
-                                     else "No change"
-    redirect RedirectTemporary JournalPage
+          setMessage $ string $ printf "Saved journal to %s\n" (show f)
+          redirect RedirectTemporary JournalPage)
+       jE
 

Hledger/Cli/Tests.hs

@@ -61,8 +61,8 @@ tests = TestList [
    tests_Hledger_Commands,
 
    "account directive" ~:
-   let sameParse str1 str2 = do j1 <- readJournal Nothing str1
-                                j2 <- readJournal Nothing str2
+   let sameParse str1 str2 = do j1 <- readJournal Nothing str1 >>= either error return
+                                j2 <- readJournal Nothing str2 >>= either error return
                                 j1 `is` j2{filereadtime=filereadtime j1, jtext=jtext j1}
    in TestList
    [
@@ -238,12 +238,12 @@ tests = TestList [
     ]
 
    ,"balance report with cost basis" ~: do
-      j <- readJournal Nothing $ unlines
+      j <- (readJournal Nothing $ unlines
              [""
              ,"2008/1/1 test           "
              ,"  a:b          10h @ $50"
              ,"  c:d                   "
-             ]
+             ]) >>= either error return
       let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment
       showBalanceReport [] nullfilterspec j' `is`
        unlines
@@ -384,7 +384,7 @@ tests = TestList [
     "assets:bank" `isSubAccountNameOf` "my assets" `is` False
 
   ,"default year" ~: do
-    rl <- readJournal Nothing defaultyear_ledger_str
+    rl <- readJournal Nothing defaultyear_ledger_str >>= either error return
     tdate (head $ jtxns rl) `is` fromGregorian 2009 1 1
     return ()
 

Hledger/Cli/Utils.hs

@@ -19,7 +19,6 @@ module Hledger.Cli.Utils
      writeFileWithBackupIfChanged,
     )
 where
-import Control.Exception (SomeException(..), try)
 import Hledger.Data
 import Hledger.Read
 import Hledger.Cli.Options (Opt(..),journalFilePathFromOpts) -- ,optsToFilterSpec)
@@ -46,34 +45,34 @@ withJournalDo opts args cmdname cmd = do
       runcmd = cmd opts args . costify
   if creating
    then runcmd nulljournal
-   else readJournalFile Nothing f >>= runcmd
+   else readJournalFile Nothing f >>= either error runcmd
 
 -- | Get a journal from the given string and options, or throw an error.
 readJournalWithOpts :: [Opt] -> String -> IO Journal
 readJournalWithOpts opts s = do
-    j <- readJournal Nothing s
+    j <- readJournal Nothing s >>= either error return
     let cost = CostBasis `elem` opts
     return $ (if cost then journalConvertAmountsToCost else id) j
 
--- | Re-read a journal from its data file, or return the exception that was raised.
-journalReload :: Journal -> IO (Either SomeException Journal)
-journalReload Journal{filepath=f} = try $ readJournalFile Nothing f
+-- | Re-read a journal from its data file, or return an error string.
+journalReload :: Journal -> IO (Either String Journal)
+journalReload Journal{filepath=f} = readJournalFile Nothing f
 
 -- | Re-read a journal from its data file mostly, only if the file has
 -- changed since last read (or if there is no file, ie data read from
 -- stdin). The provided options are mostly ignored. Return a journal or
--- the exception that was raised while reading it, and a flag indicating
--- whether it was re-read or not.
-journalReloadIfChanged :: [Opt] -> Journal -> IO (Bool, Either SomeException Journal)
+-- the error message while reading it, and a flag indicating whether it
+-- was re-read or not.
+journalReloadIfChanged :: [Opt] -> Journal -> IO (Either String Journal, Bool)
 journalReloadIfChanged opts j@Journal{filepath=f} = do
   changed <- journalFileIsNewer j
   if changed
    then do
      when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" f
      jE <- journalReload j
-     return (True, jE)
+     return (jE, True)
    else
-     return (False, Right j)
+     return (Right j, False)
 
 -- | Has the journal's data file changed since last parsed ?
 journalFileIsNewer :: Journal -> IO Bool

hledger-lib/Hledger/Read.hs

@@ -9,6 +9,7 @@ module Hledger.Read (
        tests_Hledger_Read,
        readJournalFile,
        readJournal,
+       journalFromPathAndString,
        myLedgerPath,
        myTimelogPath,
        myJournal,
@@ -27,7 +28,6 @@ import Safe (headDef)
 import System.Directory (getHomeDirectory)
 import System.Environment (getEnv)
 import System.FilePath ((</>))
-import System.Exit
 import System.IO (IOMode(..), withFile, hGetContents, stderr)
 #if __GLASGOW_HASKELL__ <= 610
 import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
@@ -58,20 +58,20 @@ readerForFormat s | null rs = Nothing
       rs = filter ((s==).rFormat) readers :: [Reader]
 
 -- | Read a Journal from this string (and file path), auto-detecting the
--- data format, or give an error. Tries to parse each known data format in
--- turn. If none succeed, gives the error message specific to the intended
--- data format, which if not specified is guessed from the file suffix and
--- possibly the data.
-journalFromPathAndString :: Maybe String -> FilePath -> String -> IO Journal
+-- data format, or give a useful error string. Tries to parse each known
+-- data format in turn. If none succeed, gives the error message specific
+-- to the intended data format, which if not specified is guessed from the
+-- file suffix and possibly the data.
+journalFromPathAndString :: Maybe String -> FilePath -> String -> IO (Either String Journal)
 journalFromPathAndString format fp s = do
   let readers' = case format of Just f -> case readerForFormat f of Just r -> [r]
                                                                     Nothing -> []
                                 Nothing -> readers
-  (errors, journals) <- partitionEithers `fmap` mapM try readers'
-  case journals of j:_ -> return j
-                   _   -> hPutStrLn stderr (errMsg errors) >> exitWith (ExitFailure 1)
+  (errors, journals) <- partitionEithers `fmap` mapM tryReader readers'
+  case journals of j:_ -> return $ Right j
+                   _   -> let s = errMsg errors in hPutStrLn stderr s >> return (Left s)
     where
-      try r = (runErrorT . (rParser r) fp) s
+      tryReader r = (runErrorT . (rParser r) fp) s
       errMsg [] = unknownFormatMsg
       errMsg es = printf "could not parse %s data in %s\n%s" (rFormat r) fp e
           where (r,e) = headDef (head readers, head es) $ filter detects $ zip readers es
@@ -82,14 +82,14 @@ journalFromPathAndString format fp s = do
                 fmt fs = intercalate ", " (init fs) ++ " or " ++ last fs ++ " "
 
 -- | Read a journal from this file, using the specified data format or
--- trying all known formats, or give an error (and ensure the file is closed).
-readJournalFile :: Maybe String -> FilePath -> IO Journal
+-- trying all known formats, or give an error string.
+readJournalFile :: Maybe String -> FilePath -> IO (Either String Journal)
 readJournalFile format "-" = getContents >>= journalFromPathAndString format "(stdin)"
 readJournalFile format f   = withFile f ReadMode $ \h -> hGetContents h >>= journalFromPathAndString format f
 
 -- | Read a Journal from this string, using the specified data format or
--- trying all known formats, or give an error.
-readJournal :: Maybe String -> String -> IO Journal
+-- trying all known formats, or give an error string.
+readJournal :: Maybe String -> String -> IO (Either String Journal)
 readJournal format s = journalFromPathAndString format "(string)" s
 
 -- | Get the user's default ledger file path.
@@ -110,19 +110,19 @@ myTimelogPath =
 
 -- | Read the user's default journal file, or give an error.
 myJournal :: IO Journal
-myJournal = myLedgerPath >>= readJournalFile Nothing
+myJournal = myLedgerPath >>= readJournalFile Nothing >>= either error return
 
 -- | Read the user's default timelog file, or give an error.
 myTimelog :: IO Journal
-myTimelog = myTimelogPath >>= readJournalFile Nothing
+myTimelog = myTimelogPath >>= readJournalFile Nothing >>= either error return
 
 tests_Hledger_Read = TestList
   [
 
    "ledgerFile" ~: do
     assertBool "ledgerFile should parse an empty file" (isRight $ parseWithCtx emptyCtx Journal.ledgerFile "")
-    r <- readJournal Nothing "" -- don't know how to get it from ledgerFile
-    assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r
+    jE <- readJournal Nothing "" -- don't know how to get it from ledgerFile
+    either error (assertBool "ledgerFile parsing an empty file should give an empty ledger" . null . jtxns) jE
 
   ,Journal.tests_Journal
   ,Timelog.tests_Timelog