diff --git a/Commands/Web.hs b/Commands/Web.hs index b9a1aa8ae..d2bea31be 100644 --- a/Commands/Web.hs +++ b/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
<% f l' %>
<% s %>+ +-- | 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 = ("\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 = + + + + +