From 2a2b896c1d1958e837dd900df8a09b052b9ce50a Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Fri, 9 Jul 2010 23:51:49 +0000 Subject: [PATCH] webyesod: validate the journal before accepting an edit --- Hledger/Cli/Commands/Web.hs | 29 ++++++++++++++++++++--------- Hledger/Cli/Tests.hs | 10 +++++----- Hledger/Cli/Utils.hs | 21 ++++++++++----------- hledger-lib/Hledger/Read.hs | 36 ++++++++++++++++++------------------ 4 files changed, 53 insertions(+), 43 deletions(-) diff --git a/Hledger/Cli/Commands/Web.hs b/Hledger/Cli/Commands/Web.hs index 2f1cc18b8..5b10608e8 100644 --- a/Hledger/Cli/Commands/Web.hs +++ b/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'' - liftIO $ writeFileWithBackup f tnew - setMessage $ string $ if changed then printf "Saved journal to %s\n" (show f) - else "No change" - redirect RedirectTemporary JournalPage + 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 $ printf "Saved journal to %s\n" (show f) + redirect RedirectTemporary JournalPage) + jE diff --git a/Hledger/Cli/Tests.hs b/Hledger/Cli/Tests.hs index 197eb0215..534869a45 100644 --- a/Hledger/Cli/Tests.hs +++ b/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 () diff --git a/Hledger/Cli/Utils.hs b/Hledger/Cli/Utils.hs index 698424e6b..84b60ba82 100644 --- a/Hledger/Cli/Utils.hs +++ b/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 diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index 99bd7f6ab..ce4846911 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/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