web: set up journal for yesod devel, store it in App (fixes #101)

The web app's journal state is now kept in the yesod App as an IORef,
instead of using io-storage.
yesod devel now works; it uses the journal file specified by
$LEDGER_FILE, or ~/.hledger.journal.

web: update journal state handling, fix yesod devel - WIP

hledger-web/Application.hs

@@ -5,6 +5,7 @@ module Application
     , makeFoundation
     ) where
 
+import Data.IORef
 import Import
 import Yesod.Default.Config
 import Yesod.Default.Main
@@ -21,6 +22,10 @@ import Handler.JournalEntriesR
 import Handler.RegisterR
 
 import Hledger.Web.Options (defwebopts)
+import Hledger.Data (Journal, nulljournal)
+import Hledger.Read (readJournalFile)
+import Hledger.Utils (error')
+import Hledger.Cli.Options (defcliopts, journalFilePathFromOpts)
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -31,9 +36,10 @@ mkYesodDispatch "App" resourcesApp
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeApplication :: AppConfig DefaultEnv Extra -> IO Application
-makeApplication conf = do
+makeApplication :: Journal -> AppConfig DefaultEnv Extra -> IO Application
+makeApplication j conf = do
     foundation <- makeFoundation conf
+    writeIORef (appJournal foundation) j
     app <- toWaiAppPlain foundation
     return $ logWare app
   where
@@ -44,13 +50,16 @@ makeFoundation :: AppConfig DefaultEnv Extra -> IO App
 makeFoundation conf = do
     manager <- newManager def
     s <- staticSite
-    return $ App conf s manager
-      defwebopts
+    jref <- newIORef nulljournal
+    return $ App conf s manager defwebopts jref
 
 -- for yesod devel
+-- uses the journal specified by the LEDGER_FILE env var, or ~/.hledger.journal
 getApplicationDev :: IO (Int, Application)
-getApplicationDev =
-    defaultDevelApp loader makeApplication
+getApplicationDev = do
+  f <- journalFilePathFromOpts defcliopts
+  j <- either error' id `fmap` readJournalFile Nothing Nothing f
+  defaultDevelApp loader (makeApplication j)
   where
     loader = loadConfig (configSettings Development)
         { csParseExtra = parseExtra

hledger-web/Foundation.hs

@@ -7,6 +7,7 @@ See a default Yesod app's comments for more details of each part.
 module Foundation where
 
 import Prelude
+import Data.IORef
 import Yesod
 import Yesod.Static
 import Yesod.Default.Config
@@ -26,6 +27,7 @@ import Web.ClientSession (getKey)
 import Text.Hamlet (hamletFile)
 
 import Hledger.Web.Options
+import Hledger.Data.Types
 -- import Hledger.Web.Settings
 -- import Hledger.Web.Settings.StaticFiles
 
@@ -40,6 +42,7 @@ data App = App
     , httpManager :: Manager
       --
     , appOpts    :: WebOpts
+    , appJournal :: IORef Journal
     }
 
 -- Set up i18n messages. See the message folder.

hledger-web/Handler/Utils.hs

@@ -5,12 +5,13 @@ module Handler.Utils where
 import Prelude
 import Control.Applicative ((<$>))
 import Control.Monad.IO.Class (liftIO)
+import Data.IORef
 import Data.Maybe
 import Data.Text(pack,unpack)
 import Data.Time.Calendar
 import Data.Time.Clock
 import Data.Time.Format
-import System.IO.Storage (putValue, getValue)
+-- import System.IO.Storage (putValue, getValue)
 import System.Locale (defaultTimeLocale)
 #if BLAZE_HTML_0_5
 import Text.Blaze.Html (toHtml)
@@ -70,7 +71,7 @@ getViewData :: Handler ViewData
 getViewData = do
   app        <- getYesod
   let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
-  (j, err)   <- getCurrentJournal $ copts{reportopts_=ropts{no_elide_=True}}
+  (j, err)   <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}}
   msg        <- getMessageOr err
   Just here  <- getCurrentRoute
   today      <- liftIO getCurrentDay
@@ -88,17 +89,18 @@ getViewData = do
       -- | Update our copy of the journal if the file changed. If there is an
       -- error while reloading, keep the old one and return the error, and set a
       -- ui message.
-      getCurrentJournal :: CliOpts -> Handler (Journal, Maybe String)
-      getCurrentJournal opts = do
-        j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
+      getCurrentJournal :: App -> CliOpts -> Handler (Journal, Maybe String)
+      getCurrentJournal app opts = do
+        -- XXX put this inside atomicModifyIORef' for thread safety
+        j <- liftIO $ readIORef $ appJournal app
         (jE, changed) <- liftIO $ journalReloadIfChanged opts j
         if not changed
          then return (j,Nothing)
          else case jE of
-                Right j' -> do liftIO $ putValue "hledger" "journal" j'
+                Right j' -> do liftIO $ writeIORef (appJournal app) j'
                                return (j',Nothing)
-                Left e  -> do setMessage $ "error while reading" {- ++ ": " ++ e-}
-                              return (j, Just e)
+                Left e   -> do setMessage $ "error while reading" {- ++ ": " ++ e-}
+                               return (j, Just e)
 
       -- | Get the named request parameter, or the empty string if not present.
       getParameterOrNull :: String -> Handler String

hledger-web/Hledger/Web/Main.hs

@@ -22,7 +22,7 @@ import Prelude hiding (putStrLn)
 import Control.Monad (when)
 import Data.Text (pack)
 import System.Exit (exitSuccess)
-import System.IO.Storage (withStore, putValue)
+-- import System.IO.Storage (withStore, putValue)
 import Text.Printf
 
 import Hledger
@@ -67,18 +67,8 @@ web opts j = do
 
 server :: String -> Int -> WebOpts -> Journal -> IO ()
 server baseurl port opts j = do
-  _ <- printf "Starting http server on port %d with base url %s\n" port baseurl
-  -- let a = App{getStatic=static staticdir
-  --            ,appRoot=pack baseurl
-  --            ,appOpts=opts
-  --            ,appArgs=patterns_ $ reportopts_ $ cliopts_ opts
-  --            ,appJournal=j
-  --            }
-  withStore "hledger" $ do
-    putValue "hledger" "journal" j
-
--- defaultMain (fromArgs parseExtra) makeApplication
-    app <- makeApplication (AppConfig {
+    _ <- printf "Starting http server on port %d with base url %s\n" port baseurl
+    app <- makeApplication j (AppConfig {
               appEnv = Development
             , appPort = port_ opts
             , appRoot = pack baseurl

hledger-web/Setup.hs

@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain

hledger-web/devel.hs

@@ -6,17 +6,12 @@ import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
 import Control.Concurrent (threadDelay)
-import System.IO.Storage (withStore, putValue)
-
-import Hledger (readJournalFile)
 
 main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
     forkIO $
-      withStore "hledger" $ do
-        readJournalFile Nothing Nothing "dev.journal" >>= putValue "hledger" "journal"
         runSettings defaultSettings
           { settingsPort = port
           } app