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

Migrate to Yesod 0.4

Browse Source
This commit is contained in:
michael 2010-07-14 15:43:14 +00:00
parent dbe575d5fc
commit edad75ae4b
3 changed files with 43 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CONTRIBUTORS.rst
View File

@ -12,6 +12,7 @@ hledger is brought to you by:
- Sergey Astanin - utf8 support - Sergey Astanin - utf8 support
- Nick Ingolia - parser improvements - Nick Ingolia - parser improvements
- Roman Cheplyaka - "chart" command, "add" command improvements - Roman Cheplyaka - "chart" command, "add" command improvements
- Michael Snoyman - some additions to the Yesod web interface
Developers who have not yet signed the contributor agreement: Developers who have not yet signed the contributor agreement:

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

@ -6,11 +6,10 @@ A web-based UI.
module Hledger.Cli.Commands.Web module Hledger.Cli.Commands.Web
where where
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Applicative ((<$>), (<*>))
import Data.Either import Data.Either
import Network.Wai.Handler.SimpleServer (run)
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.IO.Storage (withStore, putValue, getValue) import System.IO.Storage (withStore, putValue, getValue)
import Text.Hamlet
import Text.ParserCombinators.Parsec (parse) import Text.ParserCombinators.Parsec (parse)
import Yesod import Yesod
@ -64,7 +63,7 @@ server baseurl port opts args j = do
} }
withStore "hledger" $ do withStore "hledger" $ do
putValue "hledger" "journal" j putValue "hledger" "journal" j
toWaiApp app >>= run port basicHandler port app
data HledgerWebApp = HledgerWebApp { data HledgerWebApp = HledgerWebApp {
appOpts::[Opt] appOpts::[Opt]
@ -74,8 +73,6 @@ data HledgerWebApp = HledgerWebApp {
,appRoot::String ,appRoot::String
} }
instance Yesod HledgerWebApp where approot = appRoot
mkYesod "HledgerWebApp" [$parseRoutes| mkYesod "HledgerWebApp" [$parseRoutes|
/ IndexPage GET / IndexPage GET
/style.css StyleCss GET /style.css StyleCss GET
@ -85,6 +82,8 @@ mkYesod "HledgerWebApp" [$parseRoutes|
/balance BalancePage GET /balance BalancePage GET
|] |]
instance Yesod HledgerWebApp where approot = appRoot
getIndexPage :: Handler HledgerWebApp () getIndexPage :: Handler HledgerWebApp ()
getIndexPage = redirect RedirectTemporary JournalPage getIndexPage = redirect RedirectTemporary JournalPage
@ -108,12 +107,10 @@ getBalancePage = withLatestJournalRender showBalanceReport
withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
withLatestJournalRender reportfn = do withLatestJournalRender reportfn = do
app <- getYesod app <- getYesod
params <- getParams
t <- liftIO $ getCurrentLocalTime t <- liftIO $ getCurrentLocalTime
let head' x = if null x then "" else head x a <- fromMaybe "" <$> lookupGetParam "a"
a = head' $ params "a" p <- fromMaybe "" <$> lookupGetParam "p"
p = head' $ params "p" let opts = appOpts app ++ [Period p]
opts = appOpts app ++ [Period p]
args = appArgs app ++ [a] args = appArgs app ++ [a]
fspec = optsToFilterSpec opts args t fspec = optsToFilterSpec opts args t
-- reload journal if changed, displaying any error as a message -- reload journal if changed, displaying any error as a message
@ -129,11 +126,11 @@ withLatestJournalRender reportfn = do
msg' <- getMessage msg' <- getMessage
-- XXX work around a bug, can't get the message we set above -- XXX work around a bug, can't get the message we set above
let msg = if null err then msg' else Just $ string $ printf "Error while reading %s" (filepath j') let msg = if null err then msg' else Just $ string $ printf "Error while reading %s" (filepath j')
Just here <- getRoute Just here <- getCurrentRoute
hamletToRepHtml $ template here msg a p "hledger" s hamletToRepHtml $ template here msg a p "hledger" s
template :: HledgerWebAppRoutes -> Maybe (Html ()) -> String -> String template :: HledgerWebAppRoute -> Maybe (Html ()) -> String -> String
-> String -> String -> Hamlet HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoute
template here msg a p title content = [$hamlet| template here msg a p title content = [$hamlet|
!!! !!!
%html %html
@ -157,7 +154,7 @@ template here msg a p title content = [$hamlet|
nulltemplate = [$hamlet||] nulltemplate = [$hamlet||]
navbar :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes navbar :: HledgerWebAppRoute -> String -> String -> Hamlet HledgerWebAppRoute
navbar here a p = [$hamlet| navbar here a p = [$hamlet|
#navbar #navbar
%a.toprightlink!href=$string.hledgerurl$ hledger.org %a.toprightlink!href=$string.hledgerurl$ hledger.org
@ -168,7 +165,7 @@ navbar here a p = [$hamlet|
where navlinks' = navlinks here a p where navlinks' = navlinks here a p
searchform' = searchform here a p searchform' = searchform here a p
navlinks :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes navlinks :: HledgerWebAppRoute -> String -> String -> Hamlet HledgerWebAppRoute
navlinks here a p = [$hamlet| navlinks here a p = [$hamlet|
#navlinks #navlinks
^journallink^ $ ^journallink^ $
@ -186,7 +183,7 @@ navlinks here a p = [$hamlet|
style | here == dest = string "navlinkcurrent" style | here == dest = string "navlinkcurrent"
| otherwise = string "navlink" | otherwise = string "navlink"
searchform :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes searchform :: HledgerWebAppRoute -> String -> String -> Hamlet HledgerWebAppRoute
searchform here a p = [$hamlet| searchform here a p = [$hamlet|
%form#searchform %form#searchform
filter by: $ filter by: $
@ -209,10 +206,10 @@ searchform here a p = [$hamlet|
helplink topic label = [$hamlet|%a!href=$string.u$ $string.label$|] helplink topic label = [$hamlet|%a!href=$string.u$ $string.label$|]
where u = manualurl ++ if null topic then "" else '#':topic where u = manualurl ++ if null topic then "" else '#':topic
addform :: Hamlet HledgerWebAppRoutes addform :: Hamlet HledgerWebAppRoute
addform = [$hamlet| addform = [$hamlet|
%form!method=POST %form!method=POST
%table.form#addform!cellpadding=0!cellspacing=0!!border=0 %table.form#addform!cellpadding=0!cellspacing=0!border=0
%tr.formheading %tr.formheading
%td!colspan=4 %td!colspan=4
%span#formheading Add a transaction: %span#formheading Add a transaction:
@ -291,26 +288,29 @@ transactionfields n = [$hamlet|
postJournalPage :: Handler HledgerWebApp RepPlain postJournalPage :: Handler HledgerWebApp RepPlain
postJournalPage = do postJournalPage = do
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
-- get form input values, or basic validation errors. E means an Either value. -- get form input values. M means a Maybe value.
dateE <- runFormPost $ catchFormError $ notEmpty $ required $ input "date" (dateM, descM, acct1M, amt1M, acct2M, amt2M) <- runFormPost'
descE <- runFormPost $ catchFormError $ required $ input "description" $ (,,,,,)
acct1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "accountname1" <$> maybeStringInput "date"
amt1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "amount1" <*> maybeStringInput "descritpion"
acct2E <- runFormPost $ catchFormError $ notEmpty $ required $ input "accountname2" <*> maybeStringInput "accountname1"
amt2E <- runFormPost $ catchFormError $ input "amount2" <*> maybeStringInput "amount1"
<*> maybeStringInput "accountname2"
<*> maybeStringInput "amount2"
-- supply defaults and parse date and amounts, or get errors. -- supply defaults and parse date and amounts, or get errors.
let dateE' = either Left (either (\e -> Left [("date", showDateParseError e)]) Right . fixSmartDateStrEither today) dateE let dateE' = maybe (Left "No date provided") (either (\e -> Left ("date: " ++ showDateParseError e)) Right . fixSmartDateStrEither today) dateM
amt1E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt1E -- XXX missingamt only when missing/empty amt1E' = maybe (Left "No amount provided") (either (const (Right missingamt)) Right . parse someamount "") amt1M -- XXX missingamt only when missing/empty
amt2E' = case amt2E of Right [] -> Right missingamt amt2E' = case amt2M of Nothing -> Right missingamt
_ -> either Left (either (const (Right missingamt)) Right . parse someamount "" . head) amt2E Just amt -> (either (const (Right missingamt)) Right . parse someamount "") amt
strEs = [dateE', descE, acct1E, acct2E] toEither = maybe (Left "") Right
strEs = [dateE', Right $ fromMaybe "" descM, toEither acct1M, toEither acct2M]
amtEs = [amt1E', amt2E'] amtEs = [amt1E', amt2E']
errs = lefts strEs ++ lefts amtEs errs = lefts strEs ++ lefts amtEs
[date,desc,acct1,acct2] = rights strEs [date,desc,acct1,acct2] = rights strEs
[amt1,amt2] = rights amtEs [amt1,amt2] = rights amtEs
-- if no errors so far, generate a transaction and balance it or get the error. -- if no errors so far, generate a transaction and balance it or get the error.
tE | not $ null errs = Left errs tE | not $ null errs = Left errs
| otherwise = either (\e -> Left [[("unbalanced postings", head $ lines e)]]) Right | otherwise = either (\e -> Left ["unbalanced postings: " ++ (head $ lines e)]) Right
(balanceTransaction $ nulltransaction { (balanceTransaction $ nulltransaction {
tdate=parsedate date tdate=parsedate date
,teffectivedate=Nothing ,teffectivedate=Nothing
@ -328,7 +328,7 @@ postJournalPage = do
case tE of case tE of
Left errs -> do Left errs -> do
-- save current form values in session -- save current form values in session
setMessage $ string $ intercalate "; " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) errs setMessage $ string $ intercalate "; " errs
redirect RedirectTemporary JournalPage redirect RedirectTemporary JournalPage
Right t -> do Right t -> do
@ -341,11 +341,9 @@ postJournalPage = do
getEditPage :: Handler HledgerWebApp RepHtml getEditPage :: Handler HledgerWebApp RepHtml
getEditPage = do getEditPage = do
-- app <- getYesod -- app <- getYesod
params <- getParams
-- t <- liftIO $ getCurrentLocalTime -- t <- liftIO $ getCurrentLocalTime
let head' x = if null x then "" else head x a <- fromMaybe "" <$> lookupGetParam "a"
a = head' $ params "a" p <- fromMaybe "" <$> lookupGetParam "p"
p = head' $ params "p"
-- opts = appOpts app ++ [Period p] -- opts = appOpts app ++ [Period p]
-- args = appArgs app ++ [a] -- args = appArgs app ++ [a]
-- fspec = optsToFilterSpec opts args t -- fspec = optsToFilterSpec opts args t
@ -356,7 +354,7 @@ getEditPage = do
s <- liftIO $ if changed then readFile (filepath j) else return (jtext j) s <- liftIO $ if changed then readFile (filepath j) else return (jtext j)
-- render the page -- render the page
msg <- getMessage msg <- getMessage
Just here <- getRoute Just here <- getCurrentRoute
hamletToRepHtml $ template' here msg a p "hledger" s hamletToRepHtml $ template' here msg a p "hledger" s
template' here msg a p title content = [$hamlet| template' here msg a p title content = [$hamlet|
@ -377,10 +375,10 @@ template' here msg a p title content = [$hamlet|
metacontent = "text/html; charset=utf-8" metacontent = "text/html; charset=utf-8"
editform' = editform content editform' = editform content
editform :: String -> Hamlet HledgerWebAppRoutes editform :: String -> Hamlet HledgerWebAppRoute
editform t = [$hamlet| editform t = [$hamlet|
%form!method=POST %form!method=POST
%table.form#editform!cellpadding=0!cellspacing=0!!border=0 %table.form#editform!cellpadding=0!cellspacing=0!border=0
%tr.formheading %tr.formheading
%td!colspan=2 %td!colspan=2
%span!style=float:right; ^formhelp^ %span!style=float:right; ^formhelp^
@ -407,12 +405,13 @@ editform t = [$hamlet|
postEditPage :: Handler HledgerWebApp RepPlain postEditPage :: Handler HledgerWebApp RepPlain
postEditPage = do postEditPage = 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.
textE <- runFormPost $ catchFormError $ required $ input "text" textM <- runFormPost' $ maybeStringInput "text"
let textE = maybe (Left "No value provided") Right textM
-- display errors or add transaction -- display errors or add transaction
case textE of case textE of
Left errs -> do Left errs -> do
-- XXX should save current form values in session -- XXX should save current form values in session
setMessage $ string $ intercalate "; " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) [errs] setMessage $ string errs
redirect RedirectTemporary JournalPage redirect RedirectTemporary JournalPage
Right t' -> do Right t' -> do

6
hledger.cabal
View File

@ -104,10 +104,8 @@ executable hledger
cpp-options: -DWEB cpp-options: -DWEB
other-modules:Hledger.Cli.Commands.Web other-modules:Hledger.Cli.Commands.Web
build-depends: build-depends:
hamlet >= 0.3.1 && < 0.4 io-storage >= 0.3 && < 0.4
,io-storage >= 0.3 && < 0.4 ,yesod >= 0.4.0 && < 0.5
,wai-extra >= 0.1 && < 0.2
,yesod >= 0.3.1 && < 0.4
if flag(web610) if flag(web610)
cpp-options: -DWEB610 cpp-options: -DWEB610