diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs
index c7d0b46fd49..8f9093588f3 100644
--- a/hledger-lib/Hledger/Read.hs
+++ b/hledger-lib/Hledger/Read.hs
@@ -25,6 +25,7 @@ module Hledger.Read (
readJournalFiles,
readJournalFile,
requireJournalFileExists,
+ requireJournalFileExists',
ensureJournalFileExists,
-- * Journal parsing
@@ -172,32 +173,45 @@ readJournalFile iopts prefixedfile = do
let
(mfmt, f) = splitReaderPrefix prefixedfile
iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]}
- requireJournalFileExists f
- t <- readFileOrStdinPortably f
- -- <- T.readFile f -- or without line ending translation, for testing
- ej <- readJournal iopts' (Just f) t
- case ej of
- Left e -> return $ Left e
- Right j | new_ iopts -> do
- ds <- previousLatestDates f
- let (newj, newds) = journalFilterSinceLatestDates ds j
- when (new_save_ iopts && not (null newds)) $ saveLatestDates newds f
- return $ Right newj
- Right j -> return $ Right j
+ exists <- requireJournalFileExists' f
+ case exists of
+ Left e -> return $ Left e
+ Right _ -> do
+ t <- readFileOrStdinPortably f
+ -- <- T.readFile f -- or without line ending translation, for testing
+ ej <- readJournal iopts' (Just f) t
+ case ej of
+ Left e -> return $ Left e
+ Right j | new_ iopts -> do
+ ds <- previousLatestDates f
+ let (newj, newds) = journalFilterSinceLatestDates ds j
+ when (new_save_ iopts && not (null newds)) $ saveLatestDates newds f
+ return $ Right newj
+ Right j -> return $ Right j
--- ** utilities
-- | If the specified journal file does not exist (and is not "-"),
-- give a helpful error and quit.
requireJournalFileExists :: FilePath -> IO ()
-requireJournalFileExists "-" = return ()
requireJournalFileExists f = do
+ res <- requireJournalFileExists' f
+ either (\e -> hPutStr stderr e >> exitFailure) pure res
+
+-- | If the specified journal file does not exist (and is not "-"),
+-- give a helpful error.
+requireJournalFileExists' :: FilePath -> IO (Either String ())
+requireJournalFileExists' "-" = return $ Right ()
+requireJournalFileExists' f = do
exists <- doesFileExist f
- unless exists $ do -- XXX might not be a journal file
- hPutStr stderr $ "The hledger journal file \"" <> f <> "\" was not found.\n"
- hPutStr stderr "Please create it first, eg with \"hledger add\" or a text editor.\n"
- hPutStr stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"
- exitFailure
+ if exists then
+ return $ Right ()
+ else
+ return $ Left $ unlines [ "The hledger journal file \"" <> f <> "\" was not found."
+ , "Please create it first, eg with \"hledger add\" or a text editor."
+ , "Or, specify an existing journal file with -f or LEDGER_FILE."
+ ]
+
-- | Ensure there is a journal file at the given path, creating an empty one if needed.
-- On Windows, also ensure that the path contains no trailing dots
diff --git a/hledger-web/Hledger/Web/Application.hs b/hledger-web/Hledger/Web/Application.hs
index 4ba2c3424f7..e854974c5e7 100644
--- a/hledger-web/Hledger/Web/Application.hs
+++ b/hledger-web/Hledger/Web/Application.hs
@@ -5,17 +5,18 @@
module Hledger.Web.Application
( makeApplication
- , makeFoundation
, makeFoundationWith
) where
-import Data.IORef (newIORef, writeIORef)
+import Data.IORef (newIORef)
import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
import Network.HTTP.Client (defaultManagerSettings)
import Network.HTTP.Conduit (newManager)
+import System.IO (stderr, hPutStrLn)
import Yesod.Default.Config
-import Hledger.Data (Journal, nulljournal)
+import Hledger.Cli (withJournalTry)
+import Hledger.Data (Journal)
import Hledger.Web.Handler.AddR
import Hledger.Web.Handler.MiscR
@@ -24,7 +25,8 @@ import Hledger.Web.Handler.UploadR
import Hledger.Web.Handler.JournalR
import Hledger.Web.Handler.RegisterR
import Hledger.Web.Import
-import Hledger.Web.WebOptions (WebOpts(serve_,serve_api_), corsPolicy)
+import Hledger.Web.Error as WebError
+import Hledger.Web.WebOptions (WebOpts(serve_,serve_api_, cliopts_), corsPolicy)
-- 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
@@ -35,22 +37,19 @@ 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 :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application
-makeApplication opts' j' conf' = do
- foundation <- makeFoundation conf' opts'
- writeIORef (appJournal foundation) j'
- (logWare . (corsPolicy opts')) <$> toWaiApp foundation
+makeApplication :: WebOpts -> AppConfig DefaultEnv Extra -> IO Application
+makeApplication opts' conf' = do
+ let application = withJournalTry (toWaiApp <=< makeError) (cliopts_ opts') (toWaiApp <=< (\j -> makeFoundationWith j conf' opts'))
+ (logWare . (corsPolicy opts')) <$> application
where
logWare | development = logStdoutDev
| serve_ opts' || serve_api_ opts' = logStdout
| otherwise = id
-makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App
-makeFoundation conf opts' = do
- manager <- newManager defaultManagerSettings
- s <- staticSite
- jref <- newIORef nulljournal
- return $ App conf s manager opts' jref
+makeError :: String -> IO WebError.Error
+makeError err = do
+ hPutStrLn stderr err
+ pure $ WebError.Error err
-- Make a Foundation with the given Journal as its state.
makeFoundationWith :: Journal -> AppConfig DefaultEnv Extra -> WebOpts -> IO App
diff --git a/hledger-web/Hledger/Web/Error.hs b/hledger-web/Hledger/Web/Error.hs
new file mode 100644
index 00000000000..485463e3fda
--- /dev/null
+++ b/hledger-web/Hledger/Web/Error.hs
@@ -0,0 +1,32 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Define the web application's if something went wrong, in the usual Yesod style.
+
+module Hledger.Web.Error where
+
+import Yesod
+
+import Hledger.Web.Settings (widgetFile)
+
+newtype Error = Error { problem :: String }
+
+-- This is where we define the one route of the application if
+-- something went wrong. For a full explanation of the syntax,
+-- please see: http://www.yesodweb.com/book/handler
+mkYesod "Error" [parseRoutes|
+/ ErrorR GET
+|]
+
+instance Yesod Error
+
+-- | The error view.
+getErrorR :: Handler Html
+getErrorR = defaultLayout $ do
+ Error problem <- getYesod
+ setTitle "Error - hledger-web"
+ $(widgetFile "error")
+
diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs
index 08eacbfa0b9..f623d26085b 100644
--- a/hledger-web/Hledger/Web/Main.hs
+++ b/hledger-web/Hledger/Web/Main.hs
@@ -39,7 +39,7 @@ import Hledger.Web.WebOptions
-- Run in fast reloading mode for yesod devel.
hledgerWebDev :: IO (Int, Application)
hledgerWebDev =
- withJournalDo (cliopts_ defwebopts) (defaultDevelApp loader . makeApplication defwebopts)
+ defaultDevelApp loader (makeApplication defwebopts)
where
loader =
Yesod.Default.Config.loadConfig
@@ -48,7 +48,7 @@ hledgerWebDev =
-- Run normally.
hledgerWebMain :: IO ()
hledgerWebMain = do
- wopts@WebOpts{cliopts_=copts@CliOpts{debug_, rawopts_}} <- getHledgerWebOpts
+ wopts@WebOpts{cliopts_=_copts@CliOpts{debug_, rawopts_}} <- getHledgerWebOpts
when (debug_ > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show wopts)
if
| "help" `inRawOpts` rawopts_ -> putStr (showModeUsage webmode) >> exitSuccess
@@ -59,14 +59,12 @@ hledgerWebMain = do
| "test" `inRawOpts` rawopts_ -> do
-- remove --test and --, leaving other args for hspec
(`withArgs` hledgerWebTest) . filter (`notElem` ["--test","--"]) =<< getArgs
- | otherwise -> withJournalDo copts (web wopts)
+ | otherwise -> web wopts
-- | The hledger web command.
-web :: WebOpts -> Journal -> IO ()
-web opts j = do
- let initq = _rsQuery . reportspec_ $ cliopts_ opts
- j' = filterJournalTransactions initq j
- h = host_ opts
+web :: WebOpts -> IO ()
+web opts = do
+ let h = host_ opts
p = port_ opts
u = base_url_ opts
staticRoot = T.pack <$> file_url_ opts
@@ -76,7 +74,7 @@ web opts j = do
,appRoot = T.pack u
,appExtra = Extra "" Nothing staticRoot
}
- app <- makeApplication opts j' appconfig
+ app <- makeApplication opts appconfig
-- XXX would like to allow a host name not just an IP address here
_ <- printf "Serving web %s on %s:%d with base url %s\n"
(if serve_api_ opts then "API" else "UI and API" :: String) h p u
diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal
index 35964cd6f7c..37b4c1e9dc2 100644
--- a/hledger-web/hledger-web.cabal
+++ b/hledger-web/hledger-web.cabal
@@ -100,6 +100,7 @@ extra-source-files:
templates/default-layout-wrapper.hamlet
templates/default-layout.hamlet
templates/edit-form.hamlet
+ templates/error.hamlet
templates/journal.hamlet
templates/manage.hamlet
templates/register.hamlet
@@ -131,6 +132,7 @@ library
exposed-modules:
Hledger.Web
Hledger.Web.Application
+ Hledger.Web.Error
Hledger.Web.Foundation
Hledger.Web.Handler.AddR
Hledger.Web.Handler.EditR
diff --git a/hledger-web/templates/error.hamlet b/hledger-web/templates/error.hamlet
new file mode 100644
index 00000000000..bbd7468f692
--- /dev/null
+++ b/hledger-web/templates/error.hamlet
@@ -0,0 +1,6 @@
+
+ Woops!
+
+
+
+ #{problem}
diff --git a/hledger/Hledger/Cli/Utils.hs b/hledger/Hledger/Cli/Utils.hs
index 988dbee5124..cb711a34661 100644
--- a/hledger/Hledger/Cli/Utils.hs
+++ b/hledger/Hledger/Cli/Utils.hs
@@ -12,6 +12,7 @@ module Hledger.Cli.Utils
(
unsupportedOutputFormatError,
withJournalDo,
+ withJournalTry,
writeOutput,
writeOutputLazyText,
journalTransform,
@@ -64,14 +65,22 @@ unsupportedOutputFormatError fmt = "Sorry, output format \""++fmt++"\" is unreco
-- transformations according to options, and run a hledger command with it.
-- Or, throw an error.
withJournalDo :: CliOpts -> (Journal -> IO a) -> IO a
-withJournalDo opts cmd = do
+withJournalDo = withJournalTry error'
+
+-- | Parse the user's specified journal file(s) as a Journal, maybe apply some
+-- transformations according to options, and run a hledger command with it.
+-- Or, do the default action.
+withJournalTry :: (String -> IO a) -> CliOpts -> (Journal -> IO a) -> IO a
+withJournalTry catch opts cmd = do
-- We kludgily read the file before parsing to grab the full text, unless
-- it's stdin, or it doesn't exist and we are adding. We read it strictly
-- to let the add command work.
journalpaths <- journalFilePathFromOpts opts
files <- readJournalFiles (inputopts_ opts) journalpaths
- let transformed = journalTransform opts <$> files
- either error' cmd transformed -- PARTIAL:
+ case files of
+ Left e -> catch e
+ Right journal -> cmd $ journalTransform opts journal -- PARTIAL:
+
-- | Apply some extra post-parse transformations to the journal, if
-- specified by options. These happen after journal validation, but