hledger-0.8: Commands/Web.hs
{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
{-|
A web-based UI.
-}
module Commands.Web
where
import Codec.Binary.UTF8.String (decodeString)
import Control.Applicative.Error (Failing(Success,Failure))
import Control.Concurrent
import Control.Monad.Reader (ask)
import Data.IORef (newIORef, atomicModifyIORef)
import HSP hiding (Request,catch)
import HSP.HTML (renderAsHTML)
--import qualified HSX.XMLGenerator (XML)
import Hack.Contrib.Constants (_TextHtmlUTF8)
import Hack.Contrib.Response (set_content_type)
import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))
import Happstack.State.Control (waitForTermination)
import Network.HTTP (urlEncode, urlDecode)
import Network.Loli (loli, io, get, post, html, text, public)
--import Network.Loli.Middleware.IOConfig (ioconfig)
import Network.Loli.Type (AppUnit)
import Network.Loli.Utils (update)
import Options hiding (value)
#ifdef MAKE
import Paths_hledger_make (getDataFileName)
#else
import Paths_hledger (getDataFileName)
#endif
import System.Directory (getModificationTime)
import System.IO.Storage (withStore, putValue, getValue)
import System.Process (readProcess)
import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
import Text.ParserCombinators.Parsec (parse)
-- import Text.XHtml hiding (dir, text, param, label)
-- import Text.XHtml.Strict ((<<),(+++),(!))
import qualified HSP (Request(..))
import qualified Hack (Env, http)
import qualified Hack.Contrib.Request (inputs, params, path)
import qualified Hack.Contrib.Response (redirect)
-- import qualified Text.XHtml.Strict as H
import Commands.Add (ledgerAddTransaction)
import Commands.Balance
import Commands.Histogram
import Commands.Print
import Commands.Register
import Ledger
import Utils (openBrowserOn)
import Ledger.IO (readLedger)
-- import Debug.Trace
-- strace :: Show a => a -> a
-- strace a = trace (show a) a
tcpport = 5000 :: Int
homeurl = printf "http://localhost:%d/" tcpport
web :: [Opt] -> [String] -> Ledger -> IO ()
web opts args l = do
if Debug `elem` opts
then do
-- just run the server in the foreground
putStrLn $ printf "starting web server on port %d in debug mode" tcpport
server opts args l
else do
-- start the server (in background, so we can..) then start the web browser
printf "starting web interface on port %d\n" tcpport
tid <- forkIO $ server opts args l
putStrLn "starting web browser"
openBrowserOn homeurl
waitForTermination
putStrLn "shutting down web server..."
killThread tid
putStrLn "shutdown complete"
getenv = ask
response = update
redirect u c = response $ Hack.Contrib.Response.redirect u c
reqparam :: Hack.Env -> String -> [String]
reqparam env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
ledgerFileModifiedTime :: Ledger -> IO ClockTime
ledgerFileModifiedTime l
| null path = getClockTime
| otherwise = getModificationTime path `Prelude.catch` \_ -> getClockTime
where path = filepath $ journal l
ledgerFileReadTime :: Ledger -> ClockTime
ledgerFileReadTime l = filereadtime $ journal l
reload :: Ledger -> IO Ledger
reload l = do
l' <- readLedger (filepath $ journal l)
putValue "hledger" "ledger" l'
return l'
reloadIfChanged :: [Opt] -> [String] -> Ledger -> IO Ledger
reloadIfChanged opts _ l = do
tmod <- ledgerFileModifiedTime l
let tread = ledgerFileReadTime l
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" (filepath $ journal l)
reload l
else return l
-- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger
-- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (jtext $ journal l) (journal l)
server :: [Opt] -> [String] -> Ledger -> IO ()
server opts args l =
-- server initialisation
withStore "hledger" $ do -- IO ()
t <- getCurrentLocalTime
webfiles <- getDataFileName "web"
putValue "hledger" "ledger" l
-- XXX hack-happstack abstraction leak
hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"
runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO ()
\env -> do -- IO Response
-- general request handler
let a = intercalate "+" $ reqparam env "a"
p = intercalate "+" $ reqparam env "p"
opts' = opts ++ [Period p]
args' = args ++ (map urlDecode $ words a)
l' <- fromJust `fmap` getValue "hledger" "ledger"
l'' <- reloadIfChanged opts' args' l'
-- declare path-specific request handlers
let command :: [String] -> ([Opt] -> FilterSpec -> Ledger -> String) -> AppUnit
command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) l''
(loli $ -- State Loli () -> (Env -> IO Response)
do
get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
get "/register" $ command [] showRegisterReport
get "/histogram" $ command [] showHistogram
get "/transactions" $ ledgerpage [] l'' (showTransactions (optsToFilterSpec opts' args' t))
post "/transactions" $ handleAddform l''
get "/env" $ getenv >>= (text . show)
get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
public (Just webfiles) ["/style.css"]
get "/" $ redirect ("transactions") Nothing
) env
ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit
ledgerpage msgs l f = do
env <- getenv
l' <- io $ reloadIfChanged [] [] l
hsp msgs $ const <div><% addform env %><pre><% f l' %></pre></div>
-- | A loli directive to serve a string in pre tags within the hledger web
-- layout.
string :: [String] -> String -> AppUnit
string msgs s = hsp msgs $ const <pre><% s %></pre>
-- | A loli directive to serve a hsp template wrapped in the hledger web
-- layout. The hack environment is passed in to every hsp template as an
-- argument, since I don't see how to get it within the hsp monad.
-- A list of messages is also passed, eg for form errors.
hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
hsp msgs f = do
env <- getenv
let contenthsp = f env
pagehsp = hledgerpage env msgs title contenthsp
html =<< (io $ do
hspenv <- hackEnvToHspEnv env
(_,xml) <- runHSP html4Strict pagehsp hspenv
return $ addDoctype $ applyFixups $ renderAsHTML xml)
response $ set_content_type _TextHtmlUTF8
where
title = ""
addDoctype = ("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n" ++)
applyFixups = gsubRegexPR "\\[NBSP\\]" " "
hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
hackEnvToHspEnv env = do
x <- newIORef 0
let req = HSP.Request (reqparam env) (Hack.http env)
num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
return $ HSPEnv req num
-- htmlToHsp :: Html -> HSP XML
-- htmlToHsp h = return $ cdata $ showHtml h
-- views
hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
hledgerpage env msgs title content =
<html>
<head>
<meta http-equiv = "Content-Type" content = "text/html; charset=utf-8" />
<link rel="stylesheet" type="text/css" href="/style.css" media="all" />
<title><% title %></title>
</head>
<body>
<% navbar env %>
<div id="messages"><% intercalate ", " msgs %></div>
<div id="content"><% content %></div>
</body>
</html>
navbar :: Hack.Env -> HSP XML
navbar env =
<div id="navbar">
<a href="http://hledger.org" id="hledgerorglink">hledger.org</a>
<% navlinks env %>
<% searchform env %>
<a href="http://hledger.org/MANUAL.html" id="helplink">help</a>
</div>
getParamOrNull p = fromMaybe "" `fmap` getParam p
navlinks :: Hack.Env -> HSP XML
navlinks _ = do
a <- getParamOrNull "a"
p <- getParamOrNull "p"
let addparams=(++(printf "?a=%s&p=%s" (urlEncode a) (urlEncode p)))
link s = <a href=(addparams s) class="navlink"><% s %></a>
<div id="navlinks">
<% link "transactions" %> |
<% link "register" %> |
<% link "balance" %>
</div>
searchform :: Hack.Env -> HSP XML
searchform env = do
a <- getParamOrNull "a"
p <- getParamOrNull "p"
let resetlink | null a && null p = <span></span>
| otherwise = <span id="resetlink">[NBSP]<a href=u>reset</a></span>
where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
<form action="" id="searchform">
[NBSP]account pattern:[NBSP]<input name="a" size="20" value=a
/>[NBSP][NBSP]reporting period:[NBSP]<input name="p" size="20" value=p />
<input type="submit" name="submit" value="filter" style="display:none" />
<% resetlink %>
</form>
addform :: Hack.Env -> HSP XML
addform env = do
let inputs = Hack.Contrib.Request.inputs env
date = decodeString $ fromMaybe "" $ 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 />[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" /></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 :: Ledger -> AppUnit
handleAddform l = 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
t = Transaction {
tdate = parsedate $ fixSmartDateStr today date
,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', berr) = case balanceTransaction t of
Right t'' -> (t'', [])
Left e -> (t, [e])
errs = concat [
validateDate date
,validateDesc desc
,validateAcct1 acct1
,validateAmt1 amt1
,validateAcct2 acct2
,validateAmt2 amt2
] ++ berr
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 $ ledgerAddTransaction l t >> reload l
ledgerpage [msg] l (showTransactions (optsToFilterSpec [] [] ti))
where msg = printf "Added transaction:\n%s" (show t)