From 0df4a235afb73acbaddfc5496821b65e2a56f2bf Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Tue, 9 Apr 2013 09:33:19 -0700 Subject: [PATCH] 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 | 21 +++++++++++++++------ hledger-web/Foundation.hs | 3 +++ hledger-web/Handler/Utils.hs | 18 ++++++++++-------- hledger-web/Hledger/Web/Main.hs | 16 +++------------- hledger-web/Setup.hs | 2 -- hledger-web/devel.hs | 5 ----- 6 files changed, 31 insertions(+), 34 deletions(-) delete mode 100644 hledger-web/Setup.hs diff --git a/hledger-web/Application.hs b/hledger-web/Application.hs index 592eac9ab..f2b2beba0 100644 --- a/hledger-web/Application.hs +++ b/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 diff --git a/hledger-web/Foundation.hs b/hledger-web/Foundation.hs index 221975053..8ee3aa2d8 100644 --- a/hledger-web/Foundation.hs +++ b/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. diff --git a/hledger-web/Handler/Utils.hs b/hledger-web/Handler/Utils.hs index 94af497e7..433fb47bc 100644 --- a/hledger-web/Handler/Utils.hs +++ b/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 diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index ce2f84398..5a2c7c66b 100644 --- a/hledger-web/Hledger/Web/Main.hs +++ b/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 diff --git a/hledger-web/Setup.hs b/hledger-web/Setup.hs deleted file mode 100644 index 9a994af67..000000000 --- a/hledger-web/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/hledger-web/devel.hs b/hledger-web/devel.hs index 0acb28540..12462e576 100644 --- a/hledger-web/devel.hs +++ b/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