web: Fix error messages

hledger-web/config/routes

@@ -4,7 +4,6 @@
 /                RootR           GET
 /journal         JournalR        GET
 /register        RegisterR       GET
-/sidebar         SidebarR        GET
 /add             AddR            POST
 /edit            EditR           POST
 /import          ImportR         POST

hledger-web/hledger-web.cabal

@@ -131,7 +131,6 @@ library
       Handler.JournalR
       Handler.RegisterR
       Handler.RootR
-      Handler.SidebarR
       Hledger.Web
       Hledger.Web.Main
       Hledger.Web.WebOptions

hledger-web/package.yaml

@@ -126,7 +126,6 @@ library:
   - Handler.JournalR
   - Handler.RegisterR
   - Handler.RootR
-  - Handler.SidebarR
   - Hledger.Web
   - Hledger.Web.Main
   - Hledger.Web.WebOptions

hledger-web/src/Application.hs

@@ -23,7 +23,6 @@ import Handler.ImportR (postImportR)
 import Handler.JournalR (getJournalR)
 import Handler.RegisterR (getRegisterR)
 import Handler.RootR (getRootR)
-import Handler.SidebarR (getSidebarR)
 
 import Hledger.Data (Journal, nulljournal)
 import Hledger.Read (readJournalFile)

hledger-web/src/Foundation.hs

@@ -83,13 +83,12 @@ type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
 instance Yesod App where
   approot = ApprootMaster $ appRoot . settings
 
-  -- don't use session data
+  makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 ".hledger-web_client_session_key.aes"
-  makeSessionBackend _ = return Nothing
 
   defaultLayout widget = do
     master <- getYesod
-    lastmsg <- getMessage
     VD{am, here, j, opts, q, qopts, showsidebar} <- getViewData
+    msg <- getMessage
 
     let journalcurrent = if here == JournalR then "inacct" else "" :: Text
         ropts = reportopts_ (cliopts_ opts)
@@ -156,7 +155,6 @@ instance RenderMessage App FormMessage where
 data ViewData = VD {
      opts         :: WebOpts    -- ^ the command-line options at startup
     ,here         :: AppRoute   -- ^ the current route
-    ,msg          :: Maybe Html -- ^ the current UI message if any, possibly from the current request
     ,today        :: Day        -- ^ today's date (for queries containing relative dates)
     ,j            :: Journal    -- ^ the up-to-date parsed unfiltered journal
     ,q            :: Text       -- ^ the current q parameter, the main query expression
@@ -176,44 +174,39 @@ nullviewdata = viewdataWithDateAndParams nulldate "" ""
 -- | Make a ViewData using the given date and request parameters, and defaults elsewhere.
 viewdataWithDateAndParams :: Day -> Text -> Text -> ViewData
 viewdataWithDateAndParams d q a =
-    let (querymatcher,queryopts) = parseQuery d q
+  let (querymatcher, queryopts) = parseQuery d q
-        (acctsmatcher,acctsopts) = parseQuery d a
+      (acctsmatcher, acctsopts) = parseQuery d a
-    in VD {
+  in VD
-           opts         = defwebopts
+     { opts = defwebopts
-          ,j            = nulljournal
+     , here = RootR
-          ,here         = RootR
+     , today = d
-          ,msg          = Nothing
+     , j = nulljournal
-          ,today        = d
+     , q = q
-          ,q            = q
+     , m = querymatcher
-          ,m            = querymatcher
+     , qopts = queryopts
-          ,qopts        = queryopts
+     , am = acctsmatcher
-          ,am           = acctsmatcher
+     , aopts = acctsopts
-          ,aopts        = acctsopts
+     , showsidebar = True
-          ,showsidebar  = True
+     }
-          }
 
 -- | Gather data used by handlers and templates in the current request.
 getViewData :: Handler ViewData
 getViewData = getCurrentRoute >>= \case
-    Nothing -> return nullviewdata
+  Nothing -> return nullviewdata
-    Just here -> do
+  Just here -> do
-      App {appOpts, appJournal} <- getYesod
+    App {appOpts, appJournal = jref} <- getYesod
-      let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts
+    let opts@WebOpts {cliopts_ = copts@CliOpts {reportopts_ = ropts}} = appOpts
-      today      <- liftIO getCurrentDay
+    today <- liftIO getCurrentDay
-      (j, merr)  <- getCurrentJournal appJournal copts{reportopts_=ropts{no_elide_=True}} today
+    (j, merr) <- getCurrentJournal jref copts {reportopts_ = ropts {no_elide_ = True}} today
-      lastmsg    <- getLastMessage
+    case merr of
-      let msg = maybe lastmsg (Just . toHtml) merr
+      Just err -> setMessage (toHtml err)
-      q          <- fromMaybe "" <$> lookupGetParam "q"
+      Nothing -> pure ()
-      a          <- fromMaybe "" <$> lookupGetParam "a"
+    q <- fromMaybe "" <$> lookupGetParam "q"
-      showsidebar <- shouldShowSidebar
+    a <- fromMaybe "" <$> lookupGetParam "a"
-      return (viewdataWithDateAndParams today q a){
+    showsidebar <- shouldShowSidebar
-                   opts=opts
+    return
-                  ,msg=msg
+      (viewdataWithDateAndParams today q a)
-                  ,here=here
+      {here, j, opts, showsidebar, today}
-                  ,today=today
-                  ,j=j
-                  ,showsidebar=showsidebar
-                  }
 
 -- | Find out if the sidebar should be visible. Show it, unless there is a
 -- showsidebar cookie set to "0", or a ?sidebar=0 query parameter.
@@ -243,8 +236,3 @@ getCurrentJournal jref opts d = do
            Left e -> do
              setMessage "error while reading journal"
              return (j, Just e)
-
--- | Get the message that was set by the last request, in a
--- referentially transparent manner (allowing multiple reads).
-getLastMessage :: Handler (Maybe Html)
-getLastMessage = cached getMessage

hledger-web/src/Handler/AddR.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Handler.AddR
@@ -11,7 +10,7 @@ module Handler.AddR
 import Import
 
 import Control.Monad.State.Strict (evalStateT)
-import Data.List (sortBy)
+import Data.List (dropWhileEnd, sort)
 import qualified Data.Text as T
 import Data.Void (Void)
 import Safe (headMay)
@@ -40,7 +39,7 @@ postAddR = do
           amtparams  = parseNumberedParameters "amount" params
           pnum = length acctparams
       when (pnum == 0) (bail ["at least one posting must be entered"])
-      when (map fst acctparams /= [1..pnum] || map fst amtparams `elem` [[1..pnum], [1..pnum-1]])
+      when (map fst acctparams /= [1..pnum] || map fst amtparams `notElem` [[1..pnum], [1..pnum-1]])
         (bail ["the posting parameters are malformed"])
 
       let eaccts = runParser (accountnamep <* eof) "" . textstrip  . snd <$> acctparams
@@ -70,7 +69,7 @@ postAddR = do
 
 parseNumberedParameters :: Text -> [(Text, Text)] -> [(Int, Text)]
 parseNumberedParameters s =
-  reverse . dropWhile (T.null . snd) . sortBy (flip compare) . mapMaybe parseNum
+  dropWhileEnd (T.null . snd) . sort . mapMaybe parseNum
   where
     parseNum :: (Text, Text) -> Maybe (Int, Text)
     parseNum (k, v) = case parsewith paramnamep k of

hledger-web/src/Handler/Common.hs

@@ -84,8 +84,9 @@ numberTransactionsReportItems items = number 0 nulldate items
   where
     number :: Int -> Day -> [TransactionsReportItem] -> [(Int, Bool, Bool, TransactionsReportItem)]
     number _ _ [] = []
-    number n prevd (i@(Transaction{tdate=d},_,_,_,_,_):rest) = (n+1, newday, newmonth, i): number (n+1) d rest
+    number n prevd (i@(t, _, _, _, _, _):rest) = (n+1, newday, newmonth, i): number (n+1) d rest
       where
+        d = tdate t
         newday = d /= prevd
         newmonth = dm /= prevdm || dy /= prevdy
         (dy, dm, _) = toGregorian d
@@ -102,9 +103,9 @@ $forall t <- ts
     Just True -> "negative amount" :: Text
     _         -> "positive amount"
 
-showErrors :: ToMarkup a => [a] -> HandlerFor a ()
+showErrors :: ToMarkup a => [a] -> HandlerFor m ()
 showErrors errs = setMessage [shamlet|
 Errors:<br>
-$forall e<-errs
+$forall e <- errs
   \#{e}<br>
 |]

hledger-web/src/Handler/SidebarR.hs

@@ -1,11 +0,0 @@
--- | /sidebar
-
-module Handler.SidebarR where
-
-import Import
-
-import Handler.Common (sidebar)
-
--- | Render just the accounts sidebar, useful when opening the sidebar.
-getSidebarR :: Handler Html
-getSidebarR = withUrlRenderer . sidebar =<< getViewData

hledger-web/templates/default-layout-wrapper.hamlet

@@ -101,7 +101,7 @@ $newline never
                 <button type="button" .close data-dismiss="modal" aria-hidden="true">&times;
                 <h3 .modal-title #addLabel>Add a transaction
               <div .modal-body>
-                $maybe m <- lastmsg
+                $maybe m <- msg
                   $if isPrefixOf "Errors" (renderHtml m)
                     <div #message>#{m}
                 ^{addFormHamlet j AddR}

hledger-web/templates/default-layout.hamlet

@@ -1,5 +1,5 @@
-$maybe m <- lastmsg
+$maybe m <- msg
-  $if not $ isPrefixOf "Errors" (renderHtml m)
+  $if not (isPrefixOf "Errors" (renderHtml m))
     <div #message>#{m}
 
 <div#spacer .col-xs-2.#{topShowsm}.#{topShowmd}>