imp: Improve the experience of errors when starting the web UI

Related issue: #885

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

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

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")
+

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

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

hledger-web/templates/error.hamlet

@@ -0,0 +1,6 @@
+<h2>
+  Woops!
+
+<p>
+  <pre>
+    #{problem}

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