web: switch to hack/loli/hsp, allow web data entry, detect file changes
This commit is contained in:
Simon Michael
parent
aa4fab9468
commit
2cdc21959e
362
Commands/Web.hs
362
Commands/Web.hs
@ -1,38 +1,65 @@
|
||||
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
|
||||
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
|
||||
{-|
|
||||
A server-side-html web UI using happstack.
|
||||
A web-based UI.
|
||||
-}
|
||||
|
||||
module Commands.Web
|
||||
where
|
||||
import Control.Applicative.Error (Failing(Success,Failure))
|
||||
import Control.Concurrent
|
||||
import Happstack.Server
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.IORef (newIORef, atomicModifyIORef)
|
||||
import HSP hiding (Request)
|
||||
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 (run)
|
||||
import Happstack.State.Control (waitForTermination)
|
||||
import Network.HTTP (urlEncode, urlDecode)
|
||||
import Text.XHtml hiding (dir)
|
||||
|
||||
import Ledger
|
||||
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)
|
||||
import System.Directory (getModificationTime)
|
||||
import System.IO.Storage (withStore, putValue, getValue, getDefaultValue)
|
||||
import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
|
||||
import Text.XHtml hiding (dir, text, param, label)
|
||||
import Text.XHtml.Strict ((<<),(+++),(!))
|
||||
import qualified HSP (Request(..))
|
||||
import qualified Hack (Env, http, Response)
|
||||
import qualified Hack.Contrib.Request (inputs, params, path)
|
||||
import qualified Hack.Contrib.Response (redirect)
|
||||
import qualified Text.XHtml.Strict as H
|
||||
|
||||
import Commands.Add (addTransaction)
|
||||
import Commands.Balance
|
||||
import Commands.Register
|
||||
import Commands.Print
|
||||
import Commands.Histogram
|
||||
import Utils (filterAndCacheLedgerWithOpts, openBrowserOn)
|
||||
import Commands.Print
|
||||
import Commands.Register
|
||||
import Ledger
|
||||
import Utils (filterAndCacheLedgerWithOpts, openBrowserOn, readLedgerWithOpts)
|
||||
|
||||
-- import Debug.Trace
|
||||
-- strace :: Show a => a -> a
|
||||
-- strace a = trace (show a) a
|
||||
|
||||
tcpport = 5000
|
||||
tcpport = 3000 :: Int
|
||||
homeurl = printf "http://localhost:%d/" tcpport
|
||||
|
||||
web :: [Opt] -> [String] -> Ledger -> IO ()
|
||||
web opts args l = do
|
||||
t <- getCurrentLocalTime -- how to get this per request ?
|
||||
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
|
||||
simpleHTTP nullConf{port=tcpport} $ handlers opts args l t
|
||||
server opts args l
|
||||
else do
|
||||
-- start the server (in background, so we can..) then start the web browser
|
||||
printf "starting web interface at %s\n" homeurl
|
||||
tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ handlers opts args l t
|
||||
tid <- forkIO $ server opts args l
|
||||
putStrLn "starting web browser"
|
||||
openBrowserOn homeurl
|
||||
waitForTermination
|
||||
@ -40,77 +67,260 @@ web opts args l = do
|
||||
killThread tid
|
||||
putStrLn "shutdown complete"
|
||||
|
||||
homeurl = printf "http://localhost:%d/" tcpport
|
||||
getenv = ask
|
||||
response = update
|
||||
redirect u c = response $ Hack.Contrib.Response.redirect u c
|
||||
|
||||
handlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response
|
||||
handlers opts args l t = msum
|
||||
[
|
||||
methodSP GET $ view showBalanceReport
|
||||
,dir "balance" $ view showBalanceReport
|
||||
,dir "register" $ view showRegisterReport
|
||||
,dir "print" $ view showLedgerTransactions
|
||||
,dir "histogram" $ view showHistogram
|
||||
]
|
||||
where
|
||||
view f = withDataFn rqdata $ render f
|
||||
render f (a,p) = renderPage (a,p) $ f opts' args' l'
|
||||
where
|
||||
opts' = opts ++ [Period p]
|
||||
args' = args ++ (map urlDecode $ words a)
|
||||
-- re-filter the full ledger with the new opts
|
||||
l' = filterAndCacheLedgerWithOpts opts' args' t (rawledgertext l) (rawledger l)
|
||||
rqdata = do
|
||||
a <- look "a" `mplus` return "" -- filter patterns
|
||||
p <- look "p" `mplus` return "" -- reporting period
|
||||
return (a,p)
|
||||
renderPage :: (String, String) -> String -> ServerPartT IO Response
|
||||
renderPage (a,p) s = do
|
||||
r <- askRq
|
||||
return $ setHeader "Content-Type" "text/html" $ toResponse $ renderHtml $ hledgerview r a p s
|
||||
reqparam :: Hack.Env -> String -> [String]
|
||||
reqparam env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
|
||||
|
||||
hledgerview :: Request -> String -> String -> String -> Html
|
||||
hledgerview r a p' s = body << topbar r a p' +++ pre << s
|
||||
ledgerFileModifiedTime :: Ledger -> IO ClockTime
|
||||
ledgerFileModifiedTime l
|
||||
| null path = getClockTime
|
||||
| otherwise = getModificationTime path `Prelude.catch` \e -> getClockTime
|
||||
where path = filepath $ rawledger l
|
||||
|
||||
topbar :: Request -> String -> String -> Html
|
||||
topbar r a p' = concatHtml
|
||||
[thediv ! [thestyle "float:right; text-align:right;"] << searchform r a p'
|
||||
,thediv ! [thestyle "width:100%; font-weight:bold;"] << navlinks r a p']
|
||||
ledgerFileReadTime :: Ledger -> ClockTime
|
||||
ledgerFileReadTime l = filereadtime $ rawledger l
|
||||
|
||||
searchform :: Request -> String -> String -> Html
|
||||
searchform r a p' =
|
||||
form ! [action u] << concatHtml
|
||||
[spaceHtml +++ stringToHtml "filter by:" +++ spaceHtml
|
||||
,textfield "a" ! [size s, value a]
|
||||
,spaceHtml
|
||||
,spaceHtml +++ stringToHtml "reporting period:" +++ spaceHtml
|
||||
,textfield "p" ! [size s, value p']
|
||||
,submit "submit" "filter" ! [thestyle "display:none;"]
|
||||
,resetlink]
|
||||
reload :: Ledger -> IO Ledger
|
||||
reload l = do
|
||||
l' <- readLedgerWithOpts [] [] (filepath $ rawledger l)
|
||||
putValue "hledger" "ledger" l'
|
||||
return l'
|
||||
|
||||
reloadIfChanged :: [Opt] -> [String] -> Ledger -> IO Ledger
|
||||
reloadIfChanged opts args 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 $ rawledger l)
|
||||
reload l
|
||||
else return l
|
||||
|
||||
-- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger
|
||||
-- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (rawledgertext l) (rawledger l)
|
||||
|
||||
server :: [Opt] -> [String] -> Ledger -> IO ()
|
||||
server opts args l =
|
||||
-- server initialisation
|
||||
withStore "hledger" $ do -- IO ()
|
||||
putValue "hledger" "ledger" l
|
||||
run $ -- (Env -> IO Response) -> IO ()
|
||||
\env -> do -- IO Response
|
||||
-- general request handler
|
||||
printf $ "request\n"
|
||||
tl <- getCurrentLocalTime
|
||||
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] -> [String] -> Ledger -> String) -> AppUnit
|
||||
command msgs f = string msgs $ f opts' args' 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 "/ledger" $ ledgerpage [] l'' $ showLedgerTransactions opts' args'
|
||||
post "/ledger" $ 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 "Commands/Web") ["/static"]
|
||||
get "/" $ redirect (homeurl++"balance") 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
|
||||
-- another way to get them
|
||||
-- a = fromMaybe "" $ queryValue "a" r
|
||||
-- p = fromMaybe "" $ queryValue "p" r
|
||||
u = rqUri r
|
||||
s = "20"
|
||||
resetlink | null a && null p' = noHtml
|
||||
| otherwise = spaceHtml +++ anchor ! [href u] << stringToHtml "reset"
|
||||
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
|
||||
|
||||
navlinks :: Request -> String -> String -> Html
|
||||
navlinks _ a p' =
|
||||
concatHtml $ intersperse sep $ map linkto ["balance", "register", "print", "histogram"]
|
||||
-- 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="/static/style.css" media="all" />
|
||||
<title><% title %></title>
|
||||
</head>
|
||||
<body>
|
||||
<% navbar env %>
|
||||
<span id="messages"><% intercalate ", " msgs %></span>
|
||||
<div id="content"><% content %></div>
|
||||
</body>
|
||||
</html>
|
||||
|
||||
navbar :: Hack.Env -> HSP XML
|
||||
navbar env =
|
||||
<div id="navbar">
|
||||
<div style="float:right; text-align:right;"><% searchform env %></div>
|
||||
<% navlinks env %>
|
||||
</div>
|
||||
|
||||
getParamOrNull p = fromMaybe "" `fmap` getParam p
|
||||
|
||||
navlinks :: Hack.Env -> HSP XML
|
||||
navlinks env = 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 "balance" %> |
|
||||
<% link "register" %> |
|
||||
<% link "histogram" %> |
|
||||
<% link "ledger" %>
|
||||
</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>[NBSP]<a href=u>reset</a></span>
|
||||
where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
|
||||
<form action="" id="searchform">
|
||||
[NBSP]filter by:[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 = fromMaybe "" $ lookup "date" inputs
|
||||
desc = fromMaybe "" $ lookup "desc" inputs
|
||||
<form action="" id="addform" method="POST">
|
||||
<table border="0">
|
||||
<tr>
|
||||
<td>
|
||||
Date: <input size="10" name="date" value=date />[NBSP]
|
||||
Description: <input size="40" name="desc" value=desc />[NBSP]
|
||||
</td>
|
||||
</tr>
|
||||
<% transactionfields 1 env %>
|
||||
<% transactionfields 2 env %>
|
||||
<tr align="right"><td><input type="submit" value="add" /></td></tr>
|
||||
</table>
|
||||
</form>
|
||||
|
||||
transactionfields :: Int -> Hack.Env -> HSP XML
|
||||
transactionfields n env = do
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
acct = fromMaybe "" $ lookup acctvar inputs
|
||||
amt = fromMaybe "" $ lookup amtvar inputs
|
||||
<tr>
|
||||
<td>
|
||||
[NBSP][NBSP]
|
||||
Account: <input size="40" name=acctvar value=acct />[NBSP]
|
||||
Amount: <input size="10" name=amtvar value=amt />[NBSP]
|
||||
</td>
|
||||
</tr>
|
||||
where
|
||||
sep = stringToHtml " | "
|
||||
linkto s = anchor ! [href (s++q)] << s
|
||||
q' = intercalate "&" $
|
||||
(if null a then [] else [(("a="++).urlEncode) a]) ++
|
||||
(if null p' then [] else [(("p="++).urlEncode) p'])
|
||||
q = if null q' then "" else '?':q'
|
||||
numbered = (++ show n)
|
||||
acctvar = numbered "acct"
|
||||
amtvar = numbered "amt"
|
||||
|
||||
-- queryValues :: String -> Request -> [String]
|
||||
-- queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r
|
||||
handleAddform :: Ledger -> AppUnit
|
||||
handleAddform l = do
|
||||
env <- getenv
|
||||
handle $ validate env
|
||||
where
|
||||
validate :: Hack.Env -> Failing LedgerTransaction
|
||||
validate env =
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
date = fromMaybe "" $ lookup "date" inputs
|
||||
desc = fromMaybe "" $ lookup "desc" inputs
|
||||
acct1 = fromMaybe "" $ lookup "acct1" inputs
|
||||
amt1 = fromMaybe "" $ lookup "amt1" inputs
|
||||
acct2 = fromMaybe "" $ lookup "acct2" inputs
|
||||
amt2 = fromMaybe "" $ lookup "amt2" inputs
|
||||
validateDate "" = ["missing date"]
|
||||
validateDate s = []
|
||||
validateDesc "" = ["missing description"]
|
||||
validateDesc s = []
|
||||
validateAcct1 "" = ["missing account 1"]
|
||||
validateAcct1 s = []
|
||||
validateAmt1 "" = ["missing amount 1"]
|
||||
validateAmt1 s = []
|
||||
validateAcct2 "" = ["missing account 2"]
|
||||
validateAcct2 s = []
|
||||
validateAmt2 "" = ["missing amount 2"]
|
||||
validateAmt2 s = []
|
||||
t = LedgerTransaction {
|
||||
ltdate = parsedate date
|
||||
,lteffectivedate=Nothing
|
||||
,ltstatus=False
|
||||
,ltcode=""
|
||||
,ltdescription=desc
|
||||
,ltcomment=""
|
||||
,ltpostings=[
|
||||
Posting False acct1 (Mixed [dollars $ read amt1]) "" RegularPosting
|
||||
,Posting False acct2 (Mixed [dollars $ read amt2]) "" RegularPosting
|
||||
]
|
||||
,ltpreceding_comment_lines=""
|
||||
}
|
||||
errs = concat [
|
||||
validateDate date
|
||||
,validateDesc desc
|
||||
,validateAcct1 acct1
|
||||
,validateAmt1 amt1
|
||||
,validateAcct2 acct2
|
||||
,validateAmt2 amt2
|
||||
]
|
||||
errs' | null errs = either (:[]) (const []) (balanceLedgerTransaction t)
|
||||
| otherwise = errs
|
||||
in
|
||||
case null errs' of
|
||||
False -> Failure errs'
|
||||
True -> Success t
|
||||
|
||||
-- queryValue :: String -> Request -> Maybe String
|
||||
-- queryValue q r = case filter ((==q).fst) $ rqInputs r of
|
||||
-- [] -> Nothing
|
||||
-- is -> Just $ B.unpack $ inputValue $ snd $ head is
|
||||
handle :: Failing LedgerTransaction -> AppUnit
|
||||
handle (Failure errs) = hsp errs addform
|
||||
handle (Success t) = io (addTransaction l t >> reload l) >> (ledgerpage [msg] l (showLedgerTransactions [] [])) -- redirect (homeurl++"print") Nothing -- hsp [msg] addform
|
||||
where msg = printf "\nAdded transaction:\n%s" (show t)
|
||||
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-|
|
||||
|
||||
Most data types are defined here to avoid import cycles. See the
|
||||
@ -27,6 +28,7 @@ where
|
||||
import Ledger.Utils
|
||||
import qualified Data.Map as Map
|
||||
import System.Time (ClockTime)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
|
||||
type SmartDate = (String,String,String)
|
||||
@ -148,5 +150,5 @@ data Ledger = Ledger {
|
||||
rawledger :: RawLedger,
|
||||
accountnametree :: Tree AccountName,
|
||||
accountmap :: Map.Map AccountName Account
|
||||
}
|
||||
} deriving Typeable
|
||||
|
||||
|
||||
@ -130,12 +130,21 @@ executable hledger
|
||||
cpp-options: -DHAPPS
|
||||
other-modules:Commands.Web
|
||||
build-depends:
|
||||
happstack >= 0.2 && < 0.3
|
||||
,happstack-data >= 0.2 && < 0.3
|
||||
,happstack-server >= 0.2 && < 0.3
|
||||
,happstack-state >= 0.2 && < 0.3
|
||||
hsp
|
||||
,hsx
|
||||
,xhtml >= 3000.2 && < 3000.3
|
||||
,loli
|
||||
,io-storage
|
||||
,hack-contrib
|
||||
,hack
|
||||
,hack-handler-happstack
|
||||
,happstack >= 0.3 && < 0.4
|
||||
,happstack-data >= 0.3 && < 0.4
|
||||
,happstack-server >= 0.3 && < 0.4
|
||||
,happstack-state >= 0.3 && < 0.4
|
||||
,HTTP >= 4000.0 && < 4000.1
|
||||
,applicative-extras
|
||||
|
||||
|
||||
-- source-repository head
|
||||
-- type: darcs
|
||||
|
||||
Loading…
Reference in New Issue
Block a user