webyesod: a destructive wiki-style edit form for journals

Warning: this is the first hledger feature which can alter your existing
journal data.  You can now edit, or ERASE, the (top-level) journal file
through the web ui, and there is no access control. A numbered backup of
the file will be saved at each edit, in normal circumstances.

Hledger/Cli/Commands/Web.hs

@@ -79,6 +79,7 @@ mkYesod "HledgerWebApp" [$parseRoutes|
 /             IndexPage        GET
 /style.css    StyleCss         GET
 /journal      JournalPage      GET POST
+/edit         EditPage         GET POST
 /register     RegisterPage     GET
 /balance      BalancePage      GET
 |]
@@ -164,12 +165,14 @@ navbar here a p = [$hamlet|
 navlinks :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes
 navlinks here a p = [$hamlet|
  #navlinks
-  ^journallink^ | $
+  ^journallink^ $
-  ^registerlink^ | $
+  (^editlink^) $
-  ^balancelink^
+  | ^registerlink^ $
+  | ^balancelink^ $
 |]
  where
   journallink = navlink here "journal" JournalPage
+  editlink = navlink here "edit" EditPage
   registerlink = navlink here "register" RegisterPage
   balancelink = navlink here "balance" BalancePage
   navlink here s dest = [$hamlet|%a.$style$!href=@?u@ $string.s$|]
@@ -203,10 +206,9 @@ helplink topic label = [$hamlet|%a!href=$string.u$ $string.label$|]
 addform :: Hamlet HledgerWebAppRoutes
 addform = [$hamlet|
  %form!method=POST
-  %table#addform!cellpadding=0!cellspacing=0!!border=0
+  %table.form#addform!cellpadding=0!cellspacing=0!!border=0
    %tr.formheading
     %td!colspan=4
-     %span!style=float:right; ^formhelp^
      %span#formheading Add a transaction:
    %tr
     %td!colspan=4
@@ -332,3 +334,93 @@ postJournalPage = do
     setMessage $ string $ printf "Added transaction:\n%s" (show t')
     redirect RedirectTemporary JournalPage
 
+getEditPage :: Handler HledgerWebApp RepHtml
+getEditPage = do
+    -- app <- getYesod
+    params <- getParams
+    -- t <- liftIO $ getCurrentLocalTime
+    let head' x = if null x then "" else head x
+        a = head' $ params "a"
+        p = head' $ params "p"
+        -- opts = appOpts app ++ [Period p]
+        -- args = appArgs app ++ [a]
+        -- fspec = optsToFilterSpec opts args t
+    -- reload journal's text, without parsing, if changed
+    j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
+    changed <- liftIO $ journalFileIsNewer j
+    -- XXX readFile may throw an error
+    s <- liftIO $ if changed then readFile (filepath j) else return (jtext j)
+    -- render the page
+    msg <- getMessage
+    Just here <- getRoute
+    hamletToRepHtml $ template' here msg a p "hledger" s
+
+template' here msg a p title content = [$hamlet|
+!!!
+%html
+ %head
+  %title $string.title$
+  %meta!http-equiv=Content-Type!content=$string.metacontent$
+  %link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
+ %body
+  ^navbar'^
+  #messages $m$
+  ^editform'^
+|]
+ where m = fromMaybe (string "") msg
+       navbar' = navbar here a p
+       stylesheet = StyleCss
+       metacontent = "text/html; charset=utf-8"
+       editform' = editform content
+
+editform :: String -> Hamlet HledgerWebAppRoutes
+editform t = [$hamlet|
+ %form!method=POST
+  %table.form#editform!cellpadding=0!cellspacing=0!!border=0
+   %tr.formheading
+    %td!colspan=2
+     %span!style=float:right; ^formhelp^
+     %span#formheading Edit journal:
+   %tr
+    %td!colspan=2
+     %textarea!name=text!rows=50!cols=80
+      $string.t$
+   %tr#addbuttonrow
+    %td
+     %a!href=@JournalPage@ cancel
+    %td!align=right
+     %input!type=submit!value=$string.submitlabel$
+   %tr.helprow
+    %td
+    %td!align=right
+     #help $string.edithelp$
+|]
+ where
+  submitlabel = "save journal"
+  formhelp = helplink "file-format" "file format help"
+  edithelp = "Are you sure ? All previous data will be replaced"
+
+postEditPage :: Handler HledgerWebApp RepPlain
+postEditPage = do
+  -- get form input values, or basic validation errors. E means an Either value.
+  textE  <- runFormPost $ catchFormError $ required $ input "text"
+  -- display errors or add transaction
+  case textE of
+   Left errs -> do
+    -- save current form values in session
+    setMessage $ string $ intercalate "; " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) [errs]
+    redirect RedirectTemporary JournalPage
+
+   Right t' -> do
+    j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
+    filechanged' <- liftIO $ journalFileIsNewer j
+    let f = filepath j
+        told = jtext j
+        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
+

Hledger/Cli/Utils.hs

@@ -13,14 +13,18 @@ module Hledger.Cli.Utils
      journalReload,
      journalReloadIfChanged,
      journalFileModificationTime,
-     openBrowserOn
+     openBrowserOn,
+     writeFileWithBackup,
+     writeFileWithBackupIfChanged,
     )
 where
 import Hledger.Data
 import Hledger.Read
 import Hledger.Cli.Options (Opt(..),journalFilePathFromOpts) -- ,optsToFilterSpec)
-import System.Directory (doesFileExist, getModificationTime)
+import Safe (readMay)
+import System.Directory (doesFileExist, getModificationTime, getDirectoryContents, copyFile)
 import System.Exit
+import System.FilePath ((</>), splitFileName, takeDirectory)
 import System.Info (os)
 import System.Process (readProcessWithExitCode)
 import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
@@ -100,3 +104,33 @@ openBrowserOn u = trybrowsers browsers u
     -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);
     -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);
 
+-- | Back up this file with a (incrementing) numbered suffix then
+-- 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.
+writeFileWithBackupIfChanged :: FilePath -> String -> IO Bool
+writeFileWithBackupIfChanged f t = do
+  s <- readFile f
+  if t == s then return False
+            else backUpFile f >> writeFile f t >> return True
+
+-- | Back up this file with a (incrementing) numbered suffix, then
+-- overwrite it with this new text, or give an error.
+writeFileWithBackup :: FilePath -> String -> IO ()
+writeFileWithBackup f t = backUpFile f >> writeFile f t
+
+-- | Back up this file with a (incrementing) numbered suffix, or give an error.
+backUpFile :: FilePath -> IO ()
+backUpFile fp = do
+  fs <- getDirectoryContents $ takeDirectory fp
+  let (d,f) = splitFileName fp
+      versions = catMaybes $ map (f `backupNumber`) fs
+      next = maximum (0:versions) + 1
+      f' = printf "%s.%d" f next
+  copyFile fp (d </> f')
+
+-- | Does the second file represent a backup of the first, and if so which version is it ?
+backupNumber :: FilePath -> FilePath -> Maybe Int
+backupNumber f g = case matchRegexPR ("^" ++ f ++ "\\.([0-9]+)$") g of
+                        Just (_, ((_,suffix):_)) -> readMay suffix
+                        _ -> Nothing

data/web/style.css

@@ -9,11 +9,13 @@ body { font-family: "helvetica","arial", "sans serif"; margin:0; }
 #resetlink { font-size:small; }
 .toprightlink { font-size:small; margin-left:1em; float:right; }
 #messages { color:red; background-color:#ffeeee; margin:0.5em;}
-#addform { margin:1em; font-size:small; }
+.form { margin:1em; font-size:small; }
 #addform { background-color:#eeeeee; border:2px solid #dddddd; cell-padding:0; cell-spacing:0; }
+#addform { float:right; }
 #addform #descriptionrow { }
 #addform #postingrow { }
 #addform #addbuttonrow { text-align:right; }
+#editform textarea { background-color:#eeeeee; }
 #content { margin:1em; }
 .formheading td { padding-bottom:8px; }
 #formheading { font-size:medium; font-weight:bold; }

hledger-lib/Hledger/Read.hs

@@ -28,7 +28,7 @@ import System.Directory (getHomeDirectory)
 import System.Environment (getEnv)
 import System.FilePath ((</>))
 import System.Exit
-import System.IO (stderr)
+import System.IO (IOMode(..), withFile, hGetContents, stderr)
 #if __GLASGOW_HASKELL__ <= 610
 import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
 import System.IO.UTF8
@@ -82,10 +82,10 @@ 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.
+-- trying all known formats, or give an error (and ensure the file is closed).
 readJournalFile :: Maybe String -> FilePath -> IO Journal
 readJournalFile format "-" = getContents >>= journalFromPathAndString format "(stdin)"
-readJournalFile format f   = readFile f  >>= journalFromPathAndString format f
+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.