slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

web: show a proper not found page on 404

Browse Source
This commit is contained in:
Simon Michael 2016-05-06 19:30:23 -07:00
parent aac67b3d4d
commit 1b674cbb44
1 changed files with 45 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
hledger-web/Foundation.hs
View File

@ -235,51 +235,53 @@ viewdataWithDateAndParams d q a p =
-- | Gather data used by handlers and templates in the current request. -- | Gather data used by handlers and templates in the current request.
getViewData :: Handler ViewData getViewData :: Handler ViewData
getViewData = do getViewData = do
app <- getYesod mhere <- getCurrentRoute
let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app case mhere of
today <- liftIO getCurrentDay Nothing -> return nullviewdata
(j, merr) <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}} today Just here -> do
lastmsg <- getLastMessage app <- getYesod
let msg = maybe lastmsg (Just . toHtml) merr let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
Just here <- getCurrentRoute today <- liftIO getCurrentDay
q <- getParameterOrNull "q" (j, merr) <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}} today
a <- getParameterOrNull "a" lastmsg <- getLastMessage
p <- getParameterOrNull "p" let msg = maybe lastmsg (Just . toHtml) merr
q <- getParameterOrNull "q"
a <- getParameterOrNull "a"
p <- getParameterOrNull "p"
-- sidebar visibility: show it, unless there is a showsidebar cookie
-- set to "0", or a ?sidebar=0 query parameter.
msidebarparam <- lookupGetParam "sidebar"
msidebarcookie <- reqCookies <$> getRequest >>= return . lookup "showsidebar"
let showsidebar = maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
-- sidebar visibility: show it, unless there is a showsidebar cookie return (viewdataWithDateAndParams today q a p){
-- set to "0", or a ?sidebar=0 query parameter. opts=opts
msidebarparam <- lookupGetParam "sidebar" ,msg=msg
msidebarcookie <- reqCookies <$> getRequest >>= return . lookup "showsidebar" ,here=here
let showsidebar = maybe (msidebarcookie /= Just "0") (/="0") msidebarparam ,today=today
,j=j
,showsidebar=showsidebar
}
where
-- | Update our copy of the journal if the file changed. If there is an
-- error while reloading, keep the old one and return the error, and set a
-- ui message.
getCurrentJournal :: App -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal app opts d = do
-- XXX put this inside atomicModifyIORef' for thread safety
j <- liftIO $ readIORef $ appJournal app
(ej, changed) <- liftIO $ journalReloadIfChanged opts d j
if not changed
then return (j,Nothing)
else case ej of
Right j' -> do liftIO $ writeIORef (appJournal app) j'
return (j',Nothing)
Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-}
return (j, Just e)
return (viewdataWithDateAndParams today q a p){ -- | Get the named request parameter, or the empty string if not present.
opts=opts getParameterOrNull :: String -> Handler String
,msg=msg getParameterOrNull p = unpack `fmap` fromMaybe "" <$> lookupGetParam (pack p)
,here=here
,today=today
,j=j
,showsidebar=showsidebar
}
where
-- | Update our copy of the journal if the file changed. If there is an
-- error while reloading, keep the old one and return the error, and set a
-- ui message.
getCurrentJournal :: App -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal app opts d = do
-- XXX put this inside atomicModifyIORef' for thread safety
j <- liftIO $ readIORef $ appJournal app
(ej, changed) <- liftIO $ journalReloadIfChanged opts d j
if not changed
then return (j,Nothing)
else case ej of
Right j' -> do liftIO $ writeIORef (appJournal app) j'
return (j',Nothing)
Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-}
return (j, Just e)
-- | Get the named request parameter, or the empty string if not present.
getParameterOrNull :: String -> Handler String
getParameterOrNull p = unpack `fmap` fromMaybe "" <$> lookupGetParam (pack p)
-- | Get the message that was set by the last request, in a -- | Get the message that was set by the last request, in a
-- referentially transparent manner (allowing multiple reads). -- referentially transparent manner (allowing multiple reads).