From c60ad797278a279af52abfe38b2f7d5cf7d85f20 Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Wed, 5 Aug 2020 14:22:46 -0700
Subject: [PATCH] web: update for new parseQuery (#1312)

Query parsing is slightly more robust ("date:" no longer gives an
internal server error, but other things still do).
---
 hledger-web/Hledger/Web/Foundation.hs | 29 +++++++++++++++++++--------
 1 file changed, 21 insertions(+), 8 deletions(-)

diff --git a/hledger-web/Hledger/Web/Foundation.hs b/hledger-web/Hledger/Web/Foundation.hs
index ba7e58aa2..9fa85b31d 100644
--- a/hledger-web/Hledger/Web/Foundation.hs
+++ b/hledger-web/Hledger/Web/Foundation.hs
@@ -16,6 +16,7 @@
 
 module Hledger.Web.Foundation where
 
+import Control.Applicative ((<|>))
 import Control.Monad (join, when)
 import qualified Data.ByteString.Char8 as BC
 import Data.Traversable (for)
@@ -201,14 +202,25 @@ getViewData = do
   App {appOpts = opts, appJournal} <- getYesod
   today <- liftIO getCurrentDay
   let copts = cliopts_ opts
-  (j, merr) <-
-    getCurrentJournal
-      appJournal
-      copts {reportopts_ = (reportopts_ copts) {no_elide_ = True}}
-      today
-  maybe (pure ()) (setMessage . toHtml) merr
+
+  -- try to read the latest journal content, keeping the old content
+  -- if there's an error
+  (j, mjerr) <- getCurrentJournal
+                appJournal
+                copts {reportopts_ = (reportopts_ copts) {no_elide_ = True}}
+                today
+
+  -- try to parse the query param, assuming no query if there's an error
   q <- fromMaybe "" <$> lookupGetParam "q"
-  let (m, qopts) = parseQuery today q
+  (m, qopts, mqerr) <- do
+    case parseQuery today q of
+      Right (m, qopts) -> return (m, qopts, Nothing)
+      Left err         -> return (Any, [], Just err)
+
+  -- if either of the above gave an error, display it
+  maybe (pure ()) (setMessage . toHtml) $ mjerr <|> mqerr
+
+  -- do some permissions checking
   caps <- case capabilitiesHeader_ opts of
     Nothing -> return (capabilities_ opts)
     Just h -> do
@@ -216,7 +228,8 @@ getViewData = do
       fmap join . for (join hs) $ \x -> case capabilityFromBS x of
         Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml (BC.unpack e))
         Right c -> pure [c]
-  return VD {opts, today, j, q, m, qopts, caps}
+
+  return VD{opts, today, j, q, m, qopts, caps}
 
 checkServerSideUiEnabled :: Handler ()
 checkServerSideUiEnabled = do