refactor: extract journal reloading, cleanup

Hledger/Cli/Commands/Web.hs

@@ -11,9 +11,7 @@ import Control.Applicative.Error (Failing(Success,Failure))
 import Control.Concurrent
 import Control.Monad.Reader (ask)
 import Data.IORef (newIORef, atomicModifyIORef)
-import System.Directory (getModificationTime)
 import System.IO.Storage (withStore, putValue, getValue)
-import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
 import Text.ParserCombinators.Parsec (parse)
 
 import Hack.Contrib.Constants (_TextHtmlUTF8)
@@ -36,7 +34,6 @@ import Hledger.Cli.Commands.Histogram
 import Hledger.Cli.Commands.Print
 import Hledger.Cli.Commands.Register
 import Hledger.Data
-import Hledger.Read
 import Hledger.Read.Journal (someamount)
 import Hledger.Cli.Options hiding (value)
 #ifdef MAKE
@@ -44,7 +41,7 @@ import Paths_hledger_make (getDataFileName)
 #else
 import Paths_hledger (getDataFileName)
 #endif
-import Hledger.Cli.Utils (openBrowserOn)
+import Hledger.Cli.Utils
 
 
 tcpport = 5000 :: Int
@@ -73,7 +70,8 @@ server opts args j =
        let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
            args' = args ++ map decodeString (reqParamUtf8 env "a")
        j' <- fromJust `fmap` getValue "hledger" "journal"
-       j'' <- journalReloadIfChanged opts' args' j'
+       (changed, j'') <- io $ journalReloadIfChanged opts j'
+       when changed $ putValue "hledger" "journal" j''
        -- declare path-specific request handlers
        let command :: [String] -> ([Opt] -> FilterSpec -> Journal -> String) -> AppUnit
            command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) j''
@@ -98,32 +96,10 @@ redirect u c = response $ Hack.Contrib.Response.redirect u c
 reqParamUtf8 :: Hack.Env -> String -> [String]
 reqParamUtf8 env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
 
-journalReloadIfChanged :: [Opt] -> [String] -> Journal -> IO Journal
-journalReloadIfChanged opts _ j@Journal{filepath=f,filereadtime=tread} = do
-  tmod <- journalFileModifiedTime j
-  let newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
-  -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
-  if newer
-   then do
-     when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" f
-     reload j
-   else return j
-
-journalFileModifiedTime :: Journal -> IO ClockTime
-journalFileModifiedTime Journal{filepath=f}
-    | null f = getClockTime
-    | otherwise = getModificationTime f `Prelude.catch` \_ -> getClockTime
-
-reload :: Journal -> IO Journal
-reload Journal{filepath=f} = do
-  j' <- readJournalFile Nothing f
-  putValue "hledger" "journal" j'
-  return j'
-            
 ledgerpage :: [String] -> Journal -> (Journal -> String) -> AppUnit
 ledgerpage msgs j f = do
   env <- getenv
-  j' <- io $ journalReloadIfChanged [] [] j
+  (_, j') <- io $ journalReloadIfChanged [] j
   hsp msgs $ const <div><% addform env %><pre><% f j' %></pre></div>
 
 -- | A loli directive to serve a string in pre tags within the hledger web
@@ -329,7 +305,7 @@ handleAddform j = do
     handle :: LocalTime -> Failing Transaction -> AppUnit
     handle _ (Failure errs) = hsp errs addform
     handle ti (Success t)   = do
-                    io $ journalAddTransaction j t >> reload j
+                    io $ journalAddTransaction j t >>= journalReload
                     ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
        where msg = printf "Added transaction:\n%s" (show t)
 

Hledger/Cli/Commands/WebYesod.hs

@@ -6,29 +6,22 @@ A web-based UI.
 module Hledger.Cli.Commands.WebYesod
 where
 
--- import Codec.Binary.UTF8.String (decodeString)
 import Control.Concurrent -- (forkIO)
 import qualified Network.Wai (Request(pathInfo))
-import System.Directory (getModificationTime)
 import System.FilePath ((</>))
 import System.IO.Storage (withStore, putValue, getValue)
-import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
 import Text.Hamlet
--- import qualified Data.ByteString.Lazy as BS
 import qualified Data.ByteString.Char8 as B
 import Yesod
--- import Yesod.Helpers.Static
 
 -- import Hledger.Cli.Commands.Add (journalAddTransaction)
 import Hledger.Cli.Commands.Balance
--- import Hledger.Cli.Commands.Histogram
 import Hledger.Cli.Commands.Print
 import Hledger.Cli.Commands.Register
 
 import Hledger.Cli.Options hiding (value)
-import Hledger.Cli.Utils (openBrowserOn)
+import Hledger.Cli.Utils
 import Hledger.Data
-import Hledger.Read
 #ifdef MAKE
 import Paths_hledger_make (getDataFileName)
 #else
@@ -106,14 +99,6 @@ getRegisterPage = withLatestJournalRender showRegisterReport
 getBalancePage :: Handler HledgerWebApp RepHtml
 getBalancePage = withLatestJournalRender showBalanceReport
 
-getStyleCss :: Handler HledgerWebApp RepPlain
-getStyleCss = do
-    app <- getYesod
-    let dir = appWebdir app
-    s <- liftIO $ readFile $ dir </> "style.css"
-    header "Content-Type" "text/css"
-    return $ RepPlain $ toContent s
-
 withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
 withLatestJournalRender f = do
     app <- getYesod
@@ -126,36 +111,19 @@ withLatestJournalRender f = do
         args = appArgs app ++ as
         fs = optsToFilterSpec opts args t
     j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
-    j' <- liftIO $ journalReloadIfChanged opts args j
+    (changed, j') <- liftIO $ journalReloadIfChanged opts j
+    when changed $ liftIO $ putValue "hledger" "journal" j'
     let content = f opts fs j'
     return $ RepHtml $ toContent $ renderHamlet id $ template req as ps "" content
     -- hamletToRepHtml $ template "" s
 
-journalReloadIfChanged :: [Opt] -> [String] -> Journal -> IO Journal
+getStyleCss :: Handler HledgerWebApp RepPlain
-journalReloadIfChanged opts _ j@Journal{filepath=f,filereadtime=tread} = do
+getStyleCss = do
-  tmod <- journalFileModifiedTime j
+    app <- getYesod
-  let newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
+    let dir = appWebdir app
-  -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
+    s <- liftIO $ readFile $ dir </> "style.css"
-  if newer
+    header "Content-Type" "text/css"
-   then do
+    return $ RepPlain $ toContent s
-     when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" f
-     reload j
-   else return j
-
-journalFileModifiedTime :: Journal -> IO ClockTime
-journalFileModifiedTime Journal{filepath=f}
-    | null f = getClockTime
-    | otherwise = getModificationTime f `Prelude.catch` \_ -> getClockTime
-
-reload :: Journal -> IO Journal
-reload Journal{filepath=f} = do
-  j' <- readJournalFile Nothing f
-  putValue "hledger" "journal" j'
-  return j'
-            
-stylesheet = "/style.css"
--- stylesheet = StaticR "/style.css"
-metacontent = "text/html; charset=utf-8"
 
 template :: Request -> [String] -> [String] -> String -> String -> Hamlet String
 template req as ps t s = [$hamlet|
@@ -173,6 +141,8 @@ template req as ps t s = [$hamlet|
 |]
  where msgs = intercalate ", " []
        navbar' = navbar req as ps
+       stylesheet = "/style.css"
+       metacontent = "text/html; charset=utf-8"
 
 navbar :: Request -> [String] -> [String] -> Hamlet String
 navbar req as ps = [$hamlet|

Hledger/Cli/Tests.hs

@@ -44,7 +44,7 @@ import Hledger.Cli.Utils
 
 -- | Run unit tests.
 runtests :: [Opt] -> [String] -> IO ()
-runtests opts args = do
+runtests _ args = do
   (counts,_) <- runner ts
   if errors counts > 0 || (failures counts > 0)
    then exitFailure

Hledger/Cli/Utils.hs

@@ -10,16 +10,20 @@ module Hledger.Cli.Utils
     (
      withJournalDo,
      readJournalWithOpts,
+     journalReload,
+     journalReloadIfChanged,
+     journalFileModificationTime,
      openBrowserOn
     )
 where
 import Hledger.Data
 import Hledger.Read
 import Hledger.Cli.Options (Opt(..),journalFilePathFromOpts) -- ,optsToFilterSpec)
-import System.Directory (doesFileExist)
+import System.Directory (doesFileExist, getModificationTime)
 import System.Exit
 import System.Info (os)
 import System.Process (readProcessWithExitCode)
+import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
 
 
 -- | Parse the user's specified journal file and run a hledger command on
@@ -45,6 +49,34 @@ readJournalWithOpts opts s = do
     let cost = CostBasis `elem` opts
     return $ (if cost then journalConvertAmountsToCost else id) j
 
+-- | Re-read a journal from its data file.
+journalReload :: Journal -> IO Journal
+journalReload Journal{filepath=f} = readJournalFile Nothing f
+
+-- | Re-read a journal from its data file using the specified options,
+-- only if the file has changed since last read (or if there is no file,
+-- ie data read from stdin). Return a journal and a flag indicating
+-- whether it was re-read or not.
+journalReloadIfChanged :: [Opt] -> Journal -> IO (Bool, Journal)
+journalReloadIfChanged opts j@Journal{filepath=f,filereadtime=tread} = do
+  tmod <- journalFileModificationTime j
+  let newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
+  -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
+  if newer
+   then do
+     when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" f
+     j' <- journalReload j
+     return (True, j')
+   else
+     return (False, j)
+
+-- | Get the last modified time of the journal's data file (or if there is no
+-- file, the current time).
+journalFileModificationTime :: Journal -> IO ClockTime
+journalFileModificationTime Journal{filepath=f}
+    | null f = getClockTime
+    | otherwise = getModificationTime f `Prelude.catch` \_ -> getClockTime
+
 -- | Attempt to open a web browser on the given url, all platforms.
 openBrowserOn :: String -> IO ExitCode
 openBrowserOn u = trybrowsers browsers u