web: new -fwebyesod flag builds an alternate yesod-based web ui
This requires ghc >= 6.12.
This commit is contained in:
Simon Michael
parent
a048705542
commit
09b44176ce
@ -18,9 +18,12 @@ module Hledger.Cli.Commands.All (
|
||||
#ifdef VTY
|
||||
module Hledger.Cli.Commands.Vty,
|
||||
#endif
|
||||
#if defined(WEB) || defined(WEBHAPPSTACK)
|
||||
#if defined(WEB)
|
||||
module Hledger.Cli.Commands.Web,
|
||||
#endif
|
||||
#if defined(WEBYESOD)
|
||||
module Hledger.Cli.Commands.WebYesod,
|
||||
#endif
|
||||
#ifdef CHART
|
||||
module Hledger.Cli.Commands.Chart,
|
||||
#endif
|
||||
@ -37,9 +40,12 @@ import Hledger.Cli.Commands.Stats
|
||||
#ifdef VTY
|
||||
import Hledger.Cli.Commands.Vty
|
||||
#endif
|
||||
#if defined(WEB) || defined(WEBHAPPSTACK)
|
||||
#if defined(WEB)
|
||||
import Hledger.Cli.Commands.Web
|
||||
#endif
|
||||
#if defined(WEBYESOD)
|
||||
import Hledger.Cli.Commands.WebYesod
|
||||
#endif
|
||||
#ifdef CHART
|
||||
import Hledger.Cli.Commands.Chart
|
||||
#endif
|
||||
@ -59,9 +65,12 @@ tests_Hledger_Commands = TestList
|
||||
-- #ifdef VTY
|
||||
-- ,Hledger.Cli.Commands.Vty.tests_Vty
|
||||
-- #endif
|
||||
-- #if defined(WEB) || defined(WEBHAPPSTACK)
|
||||
-- #if defined(WEB)
|
||||
-- ,Hledger.Cli.Commands.Web.tests_Web
|
||||
-- #endif
|
||||
-- #if defined(WEBYESOD)
|
||||
-- ,Hledger.Cli.Commands.WebYesod.tests_Web
|
||||
-- #endif
|
||||
-- #ifdef CHART
|
||||
-- ,Hledger.Cli.Commands.Chart.tests_Chart
|
||||
-- #endif
|
||||
|
||||
@ -21,12 +21,7 @@ import Hack.Contrib.Response (set_content_type)
|
||||
import qualified Hack (Env, http)
|
||||
import qualified Hack.Contrib.Request (inputs, params, path)
|
||||
import qualified Hack.Contrib.Response (redirect)
|
||||
#ifdef WEBHAPPSTACK
|
||||
import System.Process (readProcess)
|
||||
import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))
|
||||
#else
|
||||
import Hack.Handler.SimpleServer (run)
|
||||
#endif
|
||||
|
||||
import Network.Loli (loli, io, get, post, html, text, public)
|
||||
import Network.Loli.Type (AppUnit)
|
||||
@ -70,12 +65,7 @@ server opts args j =
|
||||
t <- getCurrentLocalTime
|
||||
webfiles <- getDataFileName "web"
|
||||
putValue "hledger" "journal" j
|
||||
#ifdef WEBHAPPSTACK
|
||||
hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"
|
||||
runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO ()
|
||||
#else
|
||||
run tcpport $ -- (Env -> IO Response) -> IO ()
|
||||
#endif
|
||||
\env -> do -- IO Response
|
||||
-- general request handler
|
||||
let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
|
||||
|
||||
339
Hledger/Cli/Commands/WebYesod.hs
Normal file
339
Hledger/Cli/Commands/WebYesod.hs
Normal file
@ -0,0 +1,339 @@
|
||||
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-}
|
||||
{-|
|
||||
A web-based UI.
|
||||
-}
|
||||
|
||||
module Hledger.Cli.Commands.WebYesod
|
||||
where
|
||||
|
||||
-- import Codec.Binary.UTF8.String (decodeString)
|
||||
import Control.Concurrent -- (forkIO)
|
||||
import qualified Network.Wai (Request(pathInfo))
|
||||
import System.Directory (getModificationTime)
|
||||
import System.FilePath ((</>))
|
||||
import System.IO.Storage (withStore, putValue, getValue)
|
||||
import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
|
||||
import Text.Hamlet
|
||||
-- import qualified Data.ByteString.Lazy as BS
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Yesod
|
||||
-- import Yesod.Helpers.Static
|
||||
|
||||
-- import Hledger.Cli.Commands.Add (journalAddTransaction)
|
||||
import Hledger.Cli.Commands.Balance
|
||||
-- import Hledger.Cli.Commands.Histogram
|
||||
import Hledger.Cli.Commands.Print
|
||||
import Hledger.Cli.Commands.Register
|
||||
|
||||
import Hledger.Cli.Options hiding (value)
|
||||
import Hledger.Cli.Utils (openBrowserOn)
|
||||
import Hledger.Data
|
||||
import Hledger.Read
|
||||
#ifdef MAKE
|
||||
import Paths_hledger_make (getDataFileName)
|
||||
#else
|
||||
import Paths_hledger (getDataFileName)
|
||||
#endif
|
||||
|
||||
|
||||
tcpport = 5000 :: Int
|
||||
browserdelay = 100000 -- microseconds
|
||||
homeurl = printf "http://localhost:%d" tcpport
|
||||
hledgerurl = "http://hledger.org"
|
||||
manualurl = hledgerurl++"/MANUAL.html"
|
||||
|
||||
web :: [Opt] -> [String] -> Journal -> IO ()
|
||||
web opts args j = do
|
||||
unless (Debug `elem` opts) $ forkIO browser >> return ()
|
||||
server opts args j
|
||||
|
||||
browser :: IO ()
|
||||
browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
|
||||
|
||||
server :: [Opt] -> [String] -> Journal -> IO ()
|
||||
server opts args j = do
|
||||
printf "starting web server on port %d\n" tcpport
|
||||
fp <- getDataFileName "web"
|
||||
let app = HledgerWebApp{
|
||||
appOpts=opts
|
||||
,appArgs=args
|
||||
,appJournal=j
|
||||
,appWebdir=fp
|
||||
}
|
||||
withStore "hledger" $ do -- IO ()
|
||||
putValue "hledger" "journal" j
|
||||
toWaiApp app >>= basicHandler tcpport
|
||||
|
||||
data HledgerWebApp = HledgerWebApp {
|
||||
appOpts::[Opt]
|
||||
,appArgs::[String]
|
||||
,appJournal::Journal
|
||||
,appWebdir::FilePath
|
||||
}
|
||||
|
||||
instance Yesod HledgerWebApp where approot _ = homeurl
|
||||
|
||||
mkYesod "HledgerWebApp" [$parseRoutes|
|
||||
/ IndexPage GET
|
||||
/transactions TransactionsPage GET POST
|
||||
/register RegisterPage 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 = redirect RedirectTemporary TransactionsPage
|
||||
|
||||
getTransactionsPage :: Handler HledgerWebApp RepHtml
|
||||
getTransactionsPage = withLatestJournalRender (const showTransactions)
|
||||
|
||||
postTransactionsPage :: Handler HledgerWebApp RepHtml
|
||||
postTransactionsPage = withLatestJournalRender (const showTransactions)
|
||||
|
||||
getRegisterPage :: Handler HledgerWebApp RepHtml
|
||||
getRegisterPage = withLatestJournalRender showRegisterReport
|
||||
|
||||
getBalancePage :: Handler HledgerWebApp RepHtml
|
||||
getBalancePage = withLatestJournalRender showBalanceReport
|
||||
|
||||
getStyleCss :: Handler HledgerWebApp RepPlain
|
||||
getStyleCss = do
|
||||
app <- getYesod
|
||||
let dir = appWebdir app
|
||||
s <- liftIO $ readFile $ dir </> "style.css"
|
||||
header "Content-Type" "text/css"
|
||||
return $ RepPlain $ toContent s
|
||||
|
||||
withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
|
||||
withLatestJournalRender f = do
|
||||
app <- getYesod
|
||||
req <- getRequest
|
||||
params <- getParams
|
||||
t <- liftIO $ getCurrentLocalTime
|
||||
let as = params "a"
|
||||
ps = params "p"
|
||||
opts = appOpts app ++ [Period $ unwords ps]
|
||||
args = appArgs app ++ as
|
||||
fs = optsToFilterSpec opts args t
|
||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||
j' <- liftIO $ journalReloadIfChanged opts args j
|
||||
let content = f opts fs j'
|
||||
return $ RepHtml $ toContent $ renderHamlet id $ template req as ps "" content
|
||||
-- hamletToRepHtml $ template "" s
|
||||
|
||||
journalReloadIfChanged :: [Opt] -> [String] -> Journal -> IO Journal
|
||||
journalReloadIfChanged opts _ j@Journal{filepath=f,filereadtime=tread} = do
|
||||
tmod <- journalFileModifiedTime j
|
||||
let newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
|
||||
-- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
|
||||
if newer
|
||||
then do
|
||||
when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" f
|
||||
reload j
|
||||
else return j
|
||||
|
||||
journalFileModifiedTime :: Journal -> IO ClockTime
|
||||
journalFileModifiedTime Journal{filepath=f}
|
||||
| null f = getClockTime
|
||||
| otherwise = getModificationTime f `Prelude.catch` \_ -> getClockTime
|
||||
|
||||
reload :: Journal -> IO Journal
|
||||
reload Journal{filepath=f} = do
|
||||
j' <- readJournalFile Nothing f
|
||||
putValue "hledger" "journal" j'
|
||||
return j'
|
||||
|
||||
stylesheet = "/style.css"
|
||||
-- stylesheet = StaticR "/style.css"
|
||||
metacontent = "text/html; charset=utf-8"
|
||||
|
||||
template :: Request -> [String] -> [String] -> String -> String -> Hamlet String
|
||||
template req as ps t s = [$hamlet|
|
||||
!!!
|
||||
%html
|
||||
%head
|
||||
%meta!http-equiv=Content-Type!content=$string.metacontent$
|
||||
%link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
|
||||
%title $string.t$
|
||||
%body
|
||||
^navbar'^
|
||||
#messages $string.msgs$
|
||||
#content
|
||||
%pre $string.s$
|
||||
|]
|
||||
where msgs = intercalate ", " []
|
||||
navbar' = navbar req as ps
|
||||
|
||||
navbar :: Request -> [String] -> [String] -> Hamlet String
|
||||
navbar req as ps = [$hamlet|
|
||||
#navbar
|
||||
%a#hledgerorglink!href=@hledgerurl@ hledger.org
|
||||
^navlinks'^
|
||||
^searchform'^
|
||||
%a#helplink!href=@manualurl@ help
|
||||
|]
|
||||
where navlinks' = navlinks req as ps
|
||||
searchform' = searchform req as ps
|
||||
|
||||
navlinks :: Request -> [String] -> [String] -> Hamlet String
|
||||
navlinks _ as ps = [$hamlet|
|
||||
#navlinks
|
||||
^transactionslink^ | $
|
||||
^registerlink^ | $
|
||||
^balancelink^
|
||||
|]
|
||||
where
|
||||
transactionslink = navlink "transactions"
|
||||
registerlink = navlink "register"
|
||||
balancelink = navlink "balance"
|
||||
navlink s = [$hamlet|%a.navlink!href=@u@ $string.s$|]
|
||||
where u = printf "../%s?a=%s&p=%s" s (intercalate "+" as) (intercalate "+" ps)
|
||||
|
||||
searchform :: Request -> [String] -> [String] -> Hamlet String
|
||||
searchform req as ps = [$hamlet|
|
||||
%form#searchform!action=$string.action$
|
||||
search for: $
|
||||
%input!name=a!size=20!value=$string.a$
|
||||
^ahelp^ $
|
||||
in reporting period: $
|
||||
%input!name=p!size=20!value=$string.p$
|
||||
^phelp^ $
|
||||
%input!name=submit!type=submit!value=filter!style=display:none;
|
||||
^resetlink^
|
||||
|]
|
||||
where
|
||||
action=""
|
||||
a = intercalate "+" as
|
||||
p = intercalate "+" ps
|
||||
ahelp = helplink "filter-patterns"
|
||||
phelp = helplink "period-expressions"
|
||||
resetlink
|
||||
| null a && null p = [$hamlet||]
|
||||
| otherwise = [$hamlet|%span#resetlink $
|
||||
%a!href=@u@ reset|]
|
||||
where u = B.unpack $ Network.Wai.pathInfo $ waiRequest req
|
||||
|
||||
helplink topic = [$hamlet|%a!href=@u@ ?|]
|
||||
where u = manualurl ++ if null topic then "" else '#':topic
|
||||
|
||||
{-
|
||||
|
||||
addform :: Hack.Env -> HSP XML
|
||||
addform env = do
|
||||
today <- io $ liftM showDate $ getCurrentDay
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
date = decodeString $ fromMaybe today $ lookup "date" inputs
|
||||
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
||||
<div>
|
||||
<div id="addform">
|
||||
<form action="" method="POST">
|
||||
<table border="0">
|
||||
<tr>
|
||||
<td>
|
||||
Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %>
|
||||
Description: <input size="35" name="desc" value=desc /><% nbsp %>
|
||||
</td>
|
||||
</tr>
|
||||
<% transactionfields 1 env %>
|
||||
<% transactionfields 2 env %>
|
||||
<tr id="addbuttonrow"><td><input type="submit" value="add transaction"
|
||||
/><% help "file-format" %></td></tr>
|
||||
</table>
|
||||
</form>
|
||||
</div>
|
||||
<br clear="all" />
|
||||
</div>
|
||||
|
||||
transactionfields :: Int -> Hack.Env -> HSP XML
|
||||
transactionfields n env = do
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
|
||||
amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
|
||||
<tr>
|
||||
<td>
|
||||
<% nbsp %><% nbsp %>
|
||||
Account: <input size="35" name=acctvar value=acct /><% nbsp %>
|
||||
Amount: <input size="15" name=amtvar value=amt /><% nbsp %>
|
||||
</td>
|
||||
</tr>
|
||||
where
|
||||
numbered = (++ show n)
|
||||
acctvar = numbered "acct"
|
||||
amtvar = numbered "amt"
|
||||
|
||||
handleAddform :: Journal -> AppUnit
|
||||
handleAddform j = do
|
||||
env <- getenv
|
||||
d <- io getCurrentDay
|
||||
t <- io getCurrentLocalTime
|
||||
handle t $ validate env d
|
||||
where
|
||||
validate :: Hack.Env -> Day -> Failing Transaction
|
||||
validate env today =
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
date = decodeString $ fromMaybe "today" $ lookup "date" inputs
|
||||
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
||||
acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
|
||||
amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
|
||||
acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
|
||||
amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
|
||||
validateDate "" = ["missing date"]
|
||||
validateDate _ = []
|
||||
validateDesc "" = ["missing description"]
|
||||
validateDesc _ = []
|
||||
validateAcct1 "" = ["missing account 1"]
|
||||
validateAcct1 _ = []
|
||||
validateAmt1 "" = ["missing amount 1"]
|
||||
validateAmt1 _ = []
|
||||
validateAcct2 "" = ["missing account 2"]
|
||||
validateAcct2 _ = []
|
||||
validateAmt2 _ = []
|
||||
amt1' = either (const missingamt) id $ parse someamount "" amt1
|
||||
amt2' = either (const missingamt) id $ parse someamount "" amt2
|
||||
(date', dateparseerr) = case fixSmartDateStrEither today date of
|
||||
Right d -> (d, [])
|
||||
Left e -> ("1900/01/01", [showDateParseError e])
|
||||
t = Transaction {
|
||||
tdate = parsedate date' -- date' must be parseable
|
||||
,teffectivedate=Nothing
|
||||
,tstatus=False
|
||||
,tcode=""
|
||||
,tdescription=desc
|
||||
,tcomment=""
|
||||
,tpostings=[
|
||||
Posting False acct1 amt1' "" RegularPosting (Just t')
|
||||
,Posting False acct2 amt2' "" RegularPosting (Just t')
|
||||
]
|
||||
,tpreceding_comment_lines=""
|
||||
}
|
||||
(t', balanceerr) = case balanceTransaction t of
|
||||
Right t'' -> (t'', [])
|
||||
Left e -> (t, [head $ lines e]) -- show just the error not the transaction
|
||||
errs = concat [
|
||||
validateDate date
|
||||
,dateparseerr
|
||||
,validateDesc desc
|
||||
,validateAcct1 acct1
|
||||
,validateAmt1 amt1
|
||||
,validateAcct2 acct2
|
||||
,validateAmt2 amt2
|
||||
,balanceerr
|
||||
]
|
||||
in
|
||||
case null errs of
|
||||
False -> Failure errs
|
||||
True -> Success t'
|
||||
|
||||
handle :: LocalTime -> Failing Transaction -> AppUnit
|
||||
handle _ (Failure errs) = hsp errs addform
|
||||
handle ti (Success t) = do
|
||||
io $ journalAddTransaction j t >> reload j
|
||||
ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
|
||||
where msg = printf "Added transaction:\n%s" (show t)
|
||||
|
||||
-}
|
||||
@ -70,7 +70,7 @@ main = do
|
||||
#ifdef VTY
|
||||
| cmd `isPrefixOf` "vty" = withJournalDo opts args cmd vty
|
||||
#endif
|
||||
#if defined(WEB) || defined(WEBHAPPSTACK)
|
||||
#if defined(WEB) || defined(WEBYESOD)
|
||||
| cmd `isPrefixOf` "web" = withJournalDo opts args cmd web
|
||||
#endif
|
||||
#ifdef CHART
|
||||
|
||||
@ -40,7 +40,11 @@ flag vty
|
||||
default: False
|
||||
|
||||
flag web
|
||||
description: enable the web ui (using simpleserver)
|
||||
description: enable the web ui (using loli, hack, simpleserver)
|
||||
default: False
|
||||
|
||||
flag webyesod
|
||||
description: enable the web ui (using yesod, wai, simpleserver)
|
||||
default: False
|
||||
|
||||
flag chart
|
||||
@ -107,6 +111,16 @@ executable hledger
|
||||
,HTTP >= 4000.0
|
||||
,applicative-extras
|
||||
|
||||
if flag(webyesod)
|
||||
cpp-options: -DWEBYESOD
|
||||
other-modules:Hledger.Cli.Commands.WebYesod
|
||||
build-depends:
|
||||
bytestring >= 0.9.1 && < 0.9.2
|
||||
,hamlet >= 0.3.1 && < 0.4
|
||||
,io-storage >= 0.3 && < 0.4
|
||||
,wai >= 0.1 && < 0.2
|
||||
,yesod >= 0.3.1 && < 0.4
|
||||
|
||||
if flag(chart)
|
||||
cpp-options: -DCHART
|
||||
other-modules:Hledger.Cli.Commands.Chart
|
||||
|
||||
Loading…
Reference in New Issue
Block a user