diff --git a/hledger-web/config/routes b/hledger-web/config/routes index ffd8ce11f..8aec08b24 100644 --- a/hledger-web/config/routes +++ b/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 diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 6d5caabcd..17c6c4318 100644 --- a/hledger-web/hledger-web.cabal +++ b/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 diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index 5d514cf3b..97426672a 100644 --- a/hledger-web/package.yaml +++ b/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 diff --git a/hledger-web/src/Application.hs b/hledger-web/src/Application.hs index f8809a2e6..251d6a879 100644 --- a/hledger-web/src/Application.hs +++ b/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) diff --git a/hledger-web/src/Foundation.hs b/hledger-web/src/Foundation.hs index 7bf5427b5..df7e1fbff 100644 --- a/hledger-web/src/Foundation.hs +++ b/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 _ = return Nothing + makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 ".hledger-web_client_session_key.aes" 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 - (acctsmatcher,acctsopts) = parseQuery d a - in VD { - opts = defwebopts - ,j = nulljournal - ,here = RootR - ,msg = Nothing - ,today = d - ,q = q - ,m = querymatcher - ,qopts = queryopts - ,am = acctsmatcher - ,aopts = acctsopts - ,showsidebar = True - } + let (querymatcher, queryopts) = parseQuery d q + (acctsmatcher, acctsopts) = parseQuery d a + in VD + { opts = defwebopts + , here = RootR + , today = d + , j = nulljournal + , q = q + , m = querymatcher + , qopts = queryopts + , am = acctsmatcher + , aopts = acctsopts + , showsidebar = True + } -- | Gather data used by handlers and templates in the current request. getViewData :: Handler ViewData getViewData = getCurrentRoute >>= \case - Nothing -> return nullviewdata - Just here -> do - App {appOpts, appJournal} <- getYesod - let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts - today <- liftIO getCurrentDay - (j, merr) <- getCurrentJournal appJournal copts{reportopts_=ropts{no_elide_=True}} today - lastmsg <- getLastMessage - let msg = maybe lastmsg (Just . toHtml) merr - q <- fromMaybe "" <$> lookupGetParam "q" - a <- fromMaybe "" <$> lookupGetParam "a" - showsidebar <- shouldShowSidebar - return (viewdataWithDateAndParams today q a){ - opts=opts - ,msg=msg - ,here=here - ,today=today - ,j=j - ,showsidebar=showsidebar - } + Nothing -> return nullviewdata + Just here -> do + App {appOpts, appJournal = jref} <- getYesod + let opts@WebOpts {cliopts_ = copts@CliOpts {reportopts_ = ropts}} = appOpts + today <- liftIO getCurrentDay + (j, merr) <- getCurrentJournal jref copts {reportopts_ = ropts {no_elide_ = True}} today + case merr of + Just err -> setMessage (toHtml err) + Nothing -> pure () + q <- fromMaybe "" <$> lookupGetParam "q" + a <- fromMaybe "" <$> lookupGetParam "a" + showsidebar <- shouldShowSidebar + return + (viewdataWithDateAndParams today q a) + {here, j, opts, showsidebar, today} -- | 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 diff --git a/hledger-web/src/Handler/AddR.hs b/hledger-web/src/Handler/AddR.hs index 68dce1b01..79ca33f03 100644 --- a/hledger-web/src/Handler/AddR.hs +++ b/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 diff --git a/hledger-web/src/Handler/Common.hs b/hledger-web/src/Handler/Common.hs index a008ed60b..dda64e166 100644 --- a/hledger-web/src/Handler/Common.hs +++ b/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:
-$forall e<-errs +$forall e <- errs \#{e}
|] diff --git a/hledger-web/src/Handler/SidebarR.hs b/hledger-web/src/Handler/SidebarR.hs deleted file mode 100644 index 291ca1bcd..000000000 --- a/hledger-web/src/Handler/SidebarR.hs +++ /dev/null @@ -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 diff --git a/hledger-web/templates/default-layout-wrapper.hamlet b/hledger-web/templates/default-layout-wrapper.hamlet index 09bc9f290..deb998d5b 100644 --- a/hledger-web/templates/default-layout-wrapper.hamlet +++ b/hledger-web/templates/default-layout-wrapper.hamlet @@ -101,7 +101,7 @@ $newline never