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

web: update to yesod 0.5

Browse Source
This commit is contained in:
Simon Michael 2010-09-03 19:59:23 +00:00
parent f062bde8a6
commit 5da7f8066c
2 changed files with 71 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,6 +15,8 @@ import System.IO.Storage (withStore, putValue, getValue)
import Text.ParserCombinators.Parsec (parse) import Text.ParserCombinators.Parsec (parse)
import Yesod import Yesod
import Yesod.Helpers.Static import Yesod.Helpers.Static
import Text.Hamlet
import Text.Hamlet.RT
import Hledger.Cli.Commands.Add (journalAddTransaction) import Hledger.Cli.Commands.Add (journalAddTransaction)
import Hledger.Cli.Commands.Balance import Hledger.Cli.Commands.Balance
@ -48,6 +50,8 @@ data HledgerWebApp = HledgerWebApp {
,appStatic :: Static ,appStatic :: Static
} }
type Handler = GHandler HledgerWebApp HledgerWebApp
mkYesod "HledgerWebApp" [$parseRoutes| mkYesod "HledgerWebApp" [$parseRoutes|
/static StaticR Static appStatic /static StaticR Static appStatic
/ IndexR GET / IndexR GET
@ -59,12 +63,12 @@ mkYesod "HledgerWebApp" [$parseRoutes|
/addformrt AddformRTR GET /addformrt AddformRTR GET
|] |]
style_css = StaticRoute ["style.css"] style_css = StaticRoute ["style.css"] []
hledger_js = StaticRoute ["hledger.js"] hledger_js = StaticRoute ["hledger.js"] []
jquery_js = StaticRoute ["jquery.js"] jquery_js = StaticRoute ["jquery.js"] []
jquery_url_js = StaticRoute ["jquery.url.js"] jquery_url_js = StaticRoute ["jquery.url.js"] []
dhtmlxcommon_js = StaticRoute ["dhtmlxcommon.js"] dhtmlxcommon_js = StaticRoute ["dhtmlxcommon.js"] []
dhtmlxcombo_js = StaticRoute ["dhtmlxcombo.js"] dhtmlxcombo_js = StaticRoute ["dhtmlxcombo.js"] []
instance Yesod HledgerWebApp where approot = appRoot instance Yesod HledgerWebApp where approot = appRoot
@ -74,7 +78,7 @@ defaultroute = JournalR
data TemplateData = TD { data TemplateData = TD {
here :: HledgerWebAppRoute -- ^ the current page's route here :: HledgerWebAppRoute -- ^ the current page's route
,title :: String -- ^ page's title ,title :: String -- ^ page's title
,msg :: Maybe (Html ()) -- ^ transient message ,msg :: Maybe Html -- ^ transient message
,a :: String -- ^ a (acct/desc filter pattern) parameter ,a :: String -- ^ a (acct/desc filter pattern) parameter
,p :: String -- ^ p (period expression) parameter ,p :: String -- ^ p (period expression) parameter
,j :: Journal -- ^ the current journal ,j :: Journal -- ^ the current journal
@ -124,8 +128,8 @@ server baseurl port opts args j = do
basicHandler' port Nothing app basicHandler' port Nothing app
-- | Gather all the stuff we want for a typical hledger web request handler. -- | Gather all the stuff we want for a typical hledger web request handler.
getHandlerParameters :: Handler HledgerWebApp getHandlerParameters :: Handler
(String, String, [Opt], FilterSpec, Journal, Maybe (Html ()), HledgerWebAppRoute) (String, String, [Opt], FilterSpec, Journal, Maybe Html, HledgerWebAppRoute)
getHandlerParameters = do getHandlerParameters = do
Just here <- getCurrentRoute Just here <- getCurrentRoute
(a, p, opts, fspec) <- getReportParameters (a, p, opts, fspec) <- getReportParameters
@ -134,11 +138,11 @@ getHandlerParameters = do
return (a, p, opts, fspec, j, msg, here) return (a, p, opts, fspec, j, msg, here)
where where
-- | Get current report parameters for this request. -- | Get current report parameters for this request.
getReportParameters :: Handler HledgerWebApp (String, String, [Opt], FilterSpec) getReportParameters :: Handler (String, String, [Opt], FilterSpec)
getReportParameters = do getReportParameters = do
app <- getYesod app <- getYesod
t <- liftIO $ getCurrentLocalTime t <- liftIO $ getCurrentLocalTime
a <- fromMaybe "" <$> lookupGetParam "a" a <- fromMaybe "" <$> lookupGetParam "x"
p <- fromMaybe "" <$> lookupGetParam "p" p <- fromMaybe "" <$> lookupGetParam "p"
let opts = appOpts app ++ [Period p] let opts = appOpts app ++ [Period p]
args = appArgs app ++ [a] args = appArgs app ++ [a]
@ -148,7 +152,7 @@ getHandlerParameters = do
-- | Update our copy of the journal if the file changed. If there is an -- | 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 -- error while reloading, keep the old one and return the error, and set a
-- ui message. -- ui message.
getLatestJournal :: [Opt] -> Handler HledgerWebApp (Journal, Maybe String) getLatestJournal :: [Opt] -> Handler (Journal, Maybe String)
getLatestJournal opts = do getLatestJournal opts = do
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
(jE, changed) <- liftIO $ journalReloadIfChanged opts j (jE, changed) <- liftIO $ journalReloadIfChanged opts j
@ -161,7 +165,7 @@ getHandlerParameters = do
return (j, Just e) return (j, Just e)
-- | Helper to work around a yesod feature (can't set and get a message in the same request.) -- | Helper to work around a yesod feature (can't set and get a message in the same request.)
getMessage' :: Maybe String -> Handler HledgerWebApp (Maybe (Html ())) getMessage' :: Maybe String -> Handler (Maybe Html)
getMessage' newmsgstr = do getMessage' newmsgstr = do
oldmsg <- getMessage oldmsg <- getMessage
return $ maybe oldmsg (Just . string) newmsgstr return $ maybe oldmsg (Just . string) newmsgstr
@ -169,13 +173,13 @@ getHandlerParameters = do
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- handlers & templates -- handlers & templates
getIndexR :: Handler HledgerWebApp () getIndexR :: Handler ()
getIndexR = redirect RedirectTemporary defaultroute getIndexR = redirect RedirectTemporary defaultroute
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | A combined accounts and journal view. -- | A combined accounts and journal view.
getJournalR :: Handler HledgerWebApp RepHtml getJournalR :: Handler RepHtml
getJournalR = do getJournalR = do
(a, p, opts, fspec, j, msg, here) <- getHandlerParameters (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -199,13 +203,13 @@ getJournalR = do
^jr^ ^jr^
|] |]
postJournalR :: Handler HledgerWebApp RepPlain postJournalR :: Handler RepPlain
postJournalR = postJournalOnlyR postJournalR = postJournalOnlyR
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | A combined accounts and register view. -- | A combined accounts and register view.
getRegisterR :: Handler HledgerWebApp RepHtml getRegisterR :: Handler RepHtml
getRegisterR = do getRegisterR = do
(a, p, opts, fspec, j, msg, here) <- getHandlerParameters (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -230,13 +234,13 @@ getRegisterR = do
^rr^ ^rr^
|] |]
postRegisterR :: Handler HledgerWebApp RepPlain postRegisterR :: Handler RepPlain
postRegisterR = postJournalOnlyR postRegisterR = postJournalOnlyR
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | A simple accounts and balances view like hledger balance. -- | A simple accounts and balances view like hledger balance.
getAccountsOnlyR :: Handler HledgerWebApp RepHtml getAccountsOnlyR :: Handler RepHtml
getAccountsOnlyR = do getAccountsOnlyR = do
(a, p, opts, fspec, j, msg, here) <- getHandlerParameters (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -271,7 +275,7 @@ balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet|
(True, ((acct, _, _, _):_)) -> (True, ((acct, _, _, _):_)) ->
let a' = if isAccountRegex a then a else acct let a' = if isAccountRegex a then a else acct
a'' = accountNameToAccountRegex $ parentAccountName $ accountRegexToAccountName a' a'' = accountNameToAccountRegex $ parentAccountName $ accountRegexToAccountName a'
parenturl = (here, [("a",a''), ("p",p)]) parenturl = (here, [("y",a''), ("p",p)])
in [$hamlet| in [$hamlet|
\ | $ \ | $
%a!href=@?parenturl@ show more &uarr; %a!href=@?parenturl@ show more &uarr;
@ -311,7 +315,7 @@ isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:("
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | A basic journal view, like hledger print, with editing. -- | A basic journal view, like hledger print, with editing.
getJournalOnlyR :: Handler HledgerWebApp RepHtml getJournalOnlyR :: Handler RepHtml
getJournalOnlyR = do getJournalOnlyR = do
(a, p, opts, fspec, j, msg, here) <- getHandlerParameters (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -486,7 +490,7 @@ importform = [$hamlet|
%a!href!onclick="return importformToggle()" cancel %a!href!onclick="return importformToggle()" cancel
|] |]
postJournalOnlyR :: Handler HledgerWebApp RepPlain postJournalOnlyR :: Handler RepPlain
postJournalOnlyR = do postJournalOnlyR = do
action <- runFormPost' $ maybeStringInput "action" action <- runFormPost' $ maybeStringInput "action"
case action of Just "edit" -> postEditForm case action of Just "edit" -> postEditForm
@ -494,7 +498,7 @@ postJournalOnlyR = do
_ -> postAddForm _ -> postAddForm
-- | Handle a journal add form post. -- | Handle a journal add form post.
postAddForm :: Handler HledgerWebApp RepPlain postAddForm :: Handler RepPlain
postAddForm = do postAddForm = do
(_, _, opts, _, _, _, _) <- getHandlerParameters (_, _, opts, _, _, _, _) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -550,7 +554,7 @@ postAddForm = do
redirect RedirectTemporary RegisterR redirect RedirectTemporary RegisterR
-- | Handle a journal edit form post. -- | Handle a journal edit form post.
postEditForm :: Handler HledgerWebApp RepPlain postEditForm :: Handler RepPlain
postEditForm = do postEditForm = do
-- get form input values, or basic validation errors. E means an Either value. -- get form input values, or basic validation errors. E means an Either value.
textM <- runFormPost' $ maybeStringInput "text" textM <- runFormPost' $ maybeStringInput "text"
@ -588,7 +592,7 @@ postEditForm = do
jE jE
-- | Handle an import page post. -- | Handle an import page post.
postImportForm :: Handler HledgerWebApp RepPlain postImportForm :: Handler RepPlain
postImportForm = do postImportForm = do
setMessage $ string $ "can't handle file upload yet" setMessage $ string $ "can't handle file upload yet"
redirect RedirectTemporary JournalR redirect RedirectTemporary JournalR
@ -608,7 +612,7 @@ postImportForm = do
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | A simple postings view like hledger register. -- | A simple postings view like hledger register.
getRegisterOnlyR :: Handler HledgerWebApp RepHtml getRegisterOnlyR :: Handler RepHtml
getRegisterOnlyR = do getRegisterOnlyR = do
(a, p, opts, fspec, j, msg, here) <- getHandlerParameters (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -650,7 +654,7 @@ mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | A standalone journal edit form page. -- | A standalone journal edit form page.
getEditR :: Handler HledgerWebApp RepHtml getEditR :: Handler RepHtml
getEditR = do getEditR = do
(a, p, _, _, _, msg, here) <- getHandlerParameters (a, p, _, _, _, msg, here) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -664,21 +668,21 @@ getEditR = do
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | Get the add form from template files reloaded at run-time. -- | Get the add form from template files reloaded at run-time.
getAddformRTR :: Handler HledgerWebApp RepHtml getAddformRTR :: Handler RepHtml
getAddformRTR = do getAddformRTR = do
(a, p, _, _, j, msg, here) <- getHandlerParameters (a, p, _, _, j, msg, here) <- getHandlerParameters
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
let td = mktd{here=here, title="hledger add transaction", msg=msg, a=a, p=p, j=j, today=today} let td = mktd{here=here, title="hledger add transaction", msg=msg, a=a, p=p, j=j, today=today}
descriptions = sort $ nub $ map tdescription $ jtxns j descriptions = sort $ nub $ map tdescription $ jtxns j
acctnames = sort $ journalAccountNamesUsed j acctnames = sort $ journalAccountNamesUsed j
postingData n = HDMap [ postingData n = [
("acctlabel", hdstring acctlabel) (["acctlabel"], hdstring acctlabel)
,("acctvar", hdstring acctvar) ,(["acctvar"], hdstring acctvar)
,("acctnames", HDList $ map hdstring acctnames) ,(["acctnames"], hdstringlist acctnames)
,("amtfield", HDHtml $ renderHamlet' amtfield) ,(["amtfield"], HDHtml $ renderHamlet' amtfield)
,("accthelp", hdstring accthelp) ,(["accthelp"], hdstring accthelp)
,("amthelp", hdstring amthelp) ,(["amthelp"], hdstring amthelp)
] :: HamletData HledgerWebAppRoute ] :: HamletMap HledgerWebAppRoute
where where
numbered = (++ show n) numbered = (++ show n)
acctvar = numbered "account" acctvar = numbered "account"
@ -701,43 +705,52 @@ getAddformRTR = do
) )
pfields1 <- renderHamletFile "addformpostingfields.hamlet" (postingData 1) pfields1 <- renderHamletFile "addformpostingfields.hamlet" (postingData 1)
pfields2 <- renderHamletFile "addformpostingfields.hamlet" (postingData 2) pfields2 <- renderHamletFile "addformpostingfields.hamlet" (postingData 2)
addform <- renderHamletFile "addform.hamlet" (HDMap [ addform <- renderHamletFile "addform.hamlet" ([
("date", hdstring "today") (["date"], hdstring "today")
,("desc", hdstring "") ,(["desc"], hdstring "")
,("descriptions", HDList $ map hdstring descriptions) ,(["descriptions"], hdstringlist descriptions)
,("datehelp", hdstring "eg: 2010/7/20") ,(["datehelp"], hdstring "eg: 2010/7/20")
,("deschelp", hdstring "eg: supermarket (optional)") ,(["deschelp"], hdstring "eg: supermarket (optional)")
,("postingfields1", HDHtml pfields1) ,(["postingfields1"], HDHtml pfields1)
,("postingfields2", HDHtml pfields2) ,(["postingfields2"], HDHtml pfields2)
]) ] :: HamletMap HledgerWebAppRoute)
hamletToRepHtml $ pageLayout td $ htmlAsHamlet addform hamletToRepHtml $ pageLayout td $ htmlAsHamlet addform
-- | Convert a string to a hamlet HDHtml data item.
hdstring :: String -> HamletData HledgerWebAppRoute
hdstring = HDHtml . string hdstring = HDHtml . string
instance Failure HamletException (Handler HledgerWebApp) -- | Convert a simple list of strings to hamlet's complicated HDList type.
hdstringlist :: [String] -> HamletData HledgerWebAppRoute
hdstringlist ss = HDList [ [([], hdstring s)] | s <- ss ]
instance Failure HamletException Handler
where failure = error . show where failure = error . show
renderHamletFile :: FilePath -> HamletData HledgerWebAppRoute -> Handler HledgerWebApp (Html ()) renderHamletFile :: FilePath -> HamletMap HledgerWebAppRoute -> Handler Html
renderHamletFile hfile hdata = do renderHamletFile hfile hmap = do
hrt <- readHamletFile hfile >>= parseHamletRT defaultHamletSettings hrt <- readHamletFile hfile >>= parseHamletRT defaultHamletSettings
renderHamletRT hrt hdata show renderHamletRT hrt hmap renderurlwithparams
readHamletFile :: FilePath -> Handler HledgerWebApp String renderurlwithparams u [] = show u
renderurlwithparams u ps = show u ++ "?" ++ intercalate "&" [k++"="++v | (k,v) <- ps]
readHamletFile :: FilePath -> Handler String
readHamletFile hfile = do readHamletFile hfile = do
dir <- ((</> "templates") . appDir) `fmap` getYesod dir <- ((</> "templates") . appDir) `fmap` getYesod
liftIO $ readFile $ dir </> hfile liftIO $ readFile $ dir </> hfile
htmlAsHamlet :: Html () -> Hamlet HledgerWebAppRoute htmlAsHamlet :: Html -> Hamlet HledgerWebAppRoute
htmlAsHamlet h = [$hamlet|$h$|] htmlAsHamlet h = [$hamlet|$h$|]
parseHamletRT' :: Failure HamletException m => String -> m HamletRT parseHamletRT' :: Failure HamletException m => String -> m HamletRT
parseHamletRT' s = parseHamletRT defaultHamletSettings s parseHamletRT' s = parseHamletRT defaultHamletSettings s
renderHamletRT' :: Failure HamletException m => HamletData HledgerWebAppRoute -> HamletRT -> m (Html ()) renderHamletRT' :: Failure HamletException m => HamletMap HledgerWebAppRoute -> HamletRT -> m Html
renderHamletRT' d h = renderHamletRT h d show renderHamletRT' m h = renderHamletRT h m renderurlwithparams
renderHamlet' :: Hamlet HledgerWebAppRoute -> Html () renderHamlet' :: Hamlet HledgerWebAppRoute -> Html
renderHamlet' h = h show renderHamlet' h = h renderurlwithparams
-- hamletToHamletRT :: Failure HamletException m => Hamlet HledgerWebAppRoute -> m HamletRT -- hamletToHamletRT :: Failure HamletException m => Hamlet HledgerWebAppRoute -> m HamletRT
-- hamletToHamletRT h = stringToHamletRT $ show $ unsafeByteString $ renderHamlet show h -- hamletToHamletRT h = stringToHamletRT $ show $ unsafeByteString $ renderHamlet show h
@ -805,7 +818,7 @@ navlinks td = [$hamlet|
navlink :: TemplateData -> String -> HledgerWebAppRoute -> Hamlet HledgerWebAppRoute navlink :: TemplateData -> String -> HledgerWebAppRoute -> Hamlet HledgerWebAppRoute
navlink TD{here=here,a=a,p=p} s dest = [$hamlet|%a#$s$link.$style$!href=@?u@ $s$|] navlink TD{here=here,a=a,p=p} s dest = [$hamlet|%a#$s$link.$style$!href=@?u@ $s$|]
where u = (dest, concat [(if null a then [] else [("a", a)]) where u = (dest, concat [(if null a then [] else [("z", a)])
,(if null p then [] else [("p", p)])]) ,(if null p then [] else [("p", p)])])
style | dest == here = "navlinkcurrent" style | dest == here = "navlinkcurrent"
| otherwise = "navlink" | otherwise = "navlink"
@ -849,7 +862,7 @@ filterform TD{here=here,a=a,p=p} = [$hamlet|
stopfiltering = if filtering then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering acct/desc|] else nulltemplate stopfiltering = if filtering then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering acct/desc|] else nulltemplate
where u = (here, if filteringperiod then [("p", p)] else []) where u = (here, if filteringperiod then [("p", p)] else [])
stopfilteringperiod = if filteringperiod then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering period|] else nulltemplate stopfilteringperiod = if filteringperiod then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering period|] else nulltemplate
where u = (here, if filtering then [("a", a)] else []) where u = (here, if filtering then [("q", a)] else [])
helplink :: String -> String -> Hamlet HledgerWebAppRoute helplink :: String -> String -> Hamlet HledgerWebAppRoute
helplink topic label = [$hamlet|%a!href=$u$!target=hledgerhelp $label$|] helplink topic label = [$hamlet|%a!href=$u$!target=hledgerhelp $label$|]

3
hledger.cabal
View File

@ -111,8 +111,7 @@ executable hledger
other-modules:Hledger.Cli.Commands.Web other-modules:Hledger.Cli.Commands.Web
build-depends: build-depends:
io-storage >= 0.3 && < 0.4 io-storage >= 0.3 && < 0.4
,yesod >= 0.4.1 && < 0.5 ,yesod >= 0.5.0.3 && < 0.6
,hamlet >= 0.4.2 && < 0.5
,convertible-text >= 0.3.0.1 && < 0.4 ,convertible-text >= 0.3.0.1 && < 0.4
,data-object >= 0.3.1.2 && < 0.4 ,data-object >= 0.3.1.2 && < 0.4
,failure >= 0.1 && < 0.2 ,failure >= 0.1 && < 0.2