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
<% addform env %>
<% f l' %>
+ +-- | 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
<% 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 = + + + + + <% title %> + + + <% navbar env %> + <% intercalate ", " msgs %> +
<% content %>
+ + + +navbar :: Hack.Env -> HSP XML +navbar env = + + +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 = <% s %> + + +searchform :: Hack.Env -> HSP XML +searchform env = do + a <- getParamOrNull "a" + p <- getParamOrNull "p" + let resetlink | null a && null p = + | otherwise = [NBSP]reset + where u = dropWhile (=='/') $ Hack.Contrib.Request.path env +
+ [NBSP]filter by:[NBSP][NBSP][NBSP]reporting period:[NBSP] + + <% resetlink %> +
+ +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 +
+ + + + + <% transactionfields 1 env %> + <% transactionfields 2 env %> + +
+ Date: [NBSP] + Description: [NBSP] +
+
+ +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 + + + [NBSP][NBSP] + Account: [NBSP] + Amount: [NBSP] + + 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) diff --git a/Ledger/Types.hs b/Ledger/Types.hs index 66a87def2..2541527c8 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -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 diff --git a/hledger.cabal b/hledger.cabal index b26eddcb9..e9ab8352b 100644 --- a/hledger.cabal +++ b/hledger.cabal @@ -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