slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

webyesod: validate the journal before accepting an edit

Browse Source
This commit is contained in:
Simon Michael 2010-07-09 23:51:49 +00:00
parent e510a64ec8
commit 2a2b896c1d
4 changed files with 53 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
Hledger/Cli/Commands/Web.hs
View File

@ -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

10
Hledger/Cli/Tests.hs
View File

@ -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 ()

21
Hledger/Cli/Utils.hs
View File

@ -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

36
hledger-lib/Hledger/Read.hs
View File

@ -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