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

webyesod: cleanups

Browse Source
This commit is contained in:
Simon Michael 2010-07-06 17:43:13 +00:00
parent 29b4ac9d04
commit 02d00e8d5b
1 changed files with 21 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
Hledger/Cli/Commands/Web.hs
View File

@ -5,7 +5,7 @@ A web-based UI.
module Hledger.Cli.Commands.Web module Hledger.Cli.Commands.Web
where where
import Control.Concurrent -- (forkIO) import Control.Concurrent (forkIO, threadDelay)
import Data.Either import Data.Either
import Network.Wai.Handler.SimpleServer (run) import Network.Wai.Handler.SimpleServer (run)
import System.FilePath ((</>)) import System.FilePath ((</>))
@ -73,21 +73,16 @@ instance Yesod HledgerWebApp where approot = appRoot
mkYesod "HledgerWebApp" [$parseRoutes| mkYesod "HledgerWebApp" [$parseRoutes|
/ IndexPage GET / IndexPage GET
/style.css StyleCss GET
/transactions TransactionsPage GET POST /transactions TransactionsPage GET POST
/register RegisterPage GET /register RegisterPage GET
/balance BalancePage GET /balance BalancePage GET
/style.css StyleCss GET
/params ParamsDebug GET
|] |]
getParamsDebug = do
r <- getRequest
return $ RepHtml $ toContent $ show $ reqGetParams r
getIndexPage :: Handler HledgerWebApp () getIndexPage :: Handler HledgerWebApp ()
getIndexPage = redirect RedirectTemporary TransactionsPage getIndexPage = redirect RedirectTemporary TransactionsPage
getStyleCss :: Handler HledgerWebApp RepPlain getStyleCss :: Handler HledgerWebApp ()
getStyleCss = do getStyleCss = do
app <- getYesod app <- getYesod
let dir = appWebdir app let dir = appWebdir app
@ -110,10 +105,10 @@ withLatestJournalRender reportfn = do
params <- getParams params <- getParams
t <- liftIO $ getCurrentLocalTime t <- liftIO $ getCurrentLocalTime
let head' x = if null x then "" else head x let head' x = if null x then "" else head x
as = head' $ params "a" a = head' $ params "a"
ps = head' $ params "p" p = head' $ params "p"
opts = appOpts app ++ [Period ps] opts = appOpts app ++ [Period p]
args = appArgs app ++ [as] args = appArgs app ++ [a]
fspec = optsToFilterSpec opts args t fspec = optsToFilterSpec opts args t
-- reload journal if changed -- reload journal if changed
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
@ -122,15 +117,13 @@ withLatestJournalRender reportfn = do
-- run the specified report using this request's params -- run the specified report using this request's params
let s = reportfn opts fspec j' let s = reportfn opts fspec j'
-- render the standard template -- render the standard template
req <- getRequest
msg <- getMessage msg <- getMessage
Just here <- getRoute Just here <- getRoute
hamletToRepHtml $ template here req msg as ps "hledger" s hamletToRepHtml $ template here msg a p "hledger" s
template :: HledgerWebAppRoutes template :: HledgerWebAppRoutes -> Maybe (Html ()) -> String -> String
-> Request -> Maybe (Html ()) -> String -> String
-> String -> String -> Hamlet HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes
template here req msg as ps title content = [$hamlet| template here msg a p title content = [$hamlet|
!!! !!!
%html %html
%head %head
@ -140,29 +133,28 @@ template here req msg as ps title content = [$hamlet|
%body %body
^navbar'^ ^navbar'^
#messages $m$ #messages $m$
^addform'^ ^addform^
#content #content
%pre $string.content$ %pre $string.content$
|] |]
where m = fromMaybe (string "") msg where m = fromMaybe (string "") msg
navbar' = navbar here req as ps navbar' = navbar here a p
addform' = addform req as ps
stylesheet = StyleCss stylesheet = StyleCss
metacontent = "text/html; charset=utf-8" metacontent = "text/html; charset=utf-8"
navbar :: HledgerWebAppRoutes -> Request -> String -> String -> Hamlet HledgerWebAppRoutes navbar :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes
navbar here req as ps = [$hamlet| navbar here a p = [$hamlet|
#navbar #navbar
%a#hledgerorglink!href=$string.hledgerurl$ hledger.org %a#hledgerorglink!href=$string.hledgerurl$ hledger.org
^navlinks'^ ^navlinks'^
^searchform'^ ^searchform'^
%a#helplink!href=$string.manualurl$ help %a#helplink!href=$string.manualurl$ help
|] |]
where navlinks' = navlinks req as ps where navlinks' = navlinks a p
searchform' = searchform here as ps searchform' = searchform here a p
navlinks :: Request -> String -> String -> Hamlet HledgerWebAppRoutes navlinks :: String -> String -> Hamlet HledgerWebAppRoutes
navlinks _ as ps = [$hamlet| navlinks a p = [$hamlet|
#navlinks #navlinks
^transactionslink^ | $ ^transactionslink^ | $
^registerlink^ | $ ^registerlink^ | $
@ -173,7 +165,7 @@ navlinks _ as ps = [$hamlet|
registerlink = navlink "register" RegisterPage registerlink = navlink "register" RegisterPage
balancelink = navlink "balance" BalancePage balancelink = navlink "balance" BalancePage
navlink s dest = [$hamlet|%a.navlink!href=@?u@ $string.s$|] navlink s dest = [$hamlet|%a.navlink!href=@?u@ $string.s$|]
where u = (dest, [("a", as), ("p", ps)]) where u = (dest, [("a", a), ("p", p)])
searchform :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes searchform :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes
searchform here a p = [$hamlet| searchform here a p = [$hamlet|
@ -199,8 +191,8 @@ searchform here a p = [$hamlet|
helplink topic = [$hamlet|%a!href=$string.u$ ?|] helplink topic = [$hamlet|%a!href=$string.u$ ?|]
where u = manualurl ++ if null topic then "" else '#':topic where u = manualurl ++ if null topic then "" else '#':topic
addform :: Request -> String -> String -> Hamlet HledgerWebAppRoutes addform :: Hamlet HledgerWebAppRoutes
addform _ _ _ = [$hamlet| addform = [$hamlet|
%form#addform!action=$string.action$!method=POST %form#addform!action=$string.action$!method=POST
%table!border=0 %table!border=0
%tr %tr