0f1cbef9a8
This renames RawTransaction -> Posting and Entry -> LedgerTransaction, plus a bunch more cleanups for consistency. So while ledger 3 has transactions containing postings, and so do we when speaking to users, internally we call ledger 3's transactions LedgerTransaction, and we keep our old Transaction type as well, because it's useful and used all over the place. To review: - ledger 2 had Entrys containing Transactions. - hledger 0.4 had Entrys containing RawTransactions, and Transactions which are a RawTransaction with its parent Entry's info added. Transactions are what we most work with when reporting and are ubiquitous in the code and docs. - ledger 3 has Transactions containing Postings. - hledger 0.5 now has LedgerTransactions containing Postings, with Transactions kept as before (a Posting plus it's parent's info). These could be named PartialTransactions or TransactionPostings, but it gets too verbose and obscure for devs and users.
118 lines
4.2 KiB
Haskell
118 lines
4.2 KiB
Haskell
{-|
|
|
A happs-based web UI for hledger.
|
|
-}
|
|
|
|
module WebCommand
|
|
where
|
|
import Control.Monad.Trans (liftIO)
|
|
import Data.ByteString.Lazy.UTF8 (toString)
|
|
import qualified Data.Map as M
|
|
import Data.Map ((!))
|
|
import Data.Time.Clock
|
|
import Data.Time.Format
|
|
import System.Locale
|
|
import Control.Concurrent
|
|
import qualified Data.ByteString.Lazy.Char8 as B
|
|
import Happstack.Data (defaultValue)
|
|
import Happstack.Server
|
|
import Happstack.Server.HTTP.FileServe (fileServe)
|
|
import Happstack.State.Control (waitForTermination)
|
|
import System.Cmd (system)
|
|
import System.Info (os)
|
|
import System.Exit
|
|
|
|
import Ledger
|
|
import Options
|
|
import BalanceCommand
|
|
import RegisterCommand
|
|
import PrintCommand
|
|
|
|
|
|
tcpport = 5000
|
|
|
|
web :: [Opt] -> [String] -> Ledger -> IO ()
|
|
web opts args l =
|
|
if Debug `elem` opts
|
|
then do
|
|
putStrLn $ printf "starting web server on port %d in debug mode" tcpport
|
|
simpleHTTP nullConf{port=tcpport} handlers
|
|
else do
|
|
putStrLn $ printf "starting web server on port %d" tcpport
|
|
tid <- forkIO $ simpleHTTP nullConf{port=tcpport} handlers
|
|
putStrLn "starting web browser"
|
|
openBrowserOn $ printf "http://localhost:%s/balance" (show tcpport)
|
|
waitForTermination
|
|
putStrLn "shutting down web server..."
|
|
killThread tid
|
|
putStrLn "shutdown complete"
|
|
|
|
where
|
|
handlers :: ServerPartT IO Response
|
|
handlers = msum
|
|
[dir "print" $ withDataFn (look "a") $ \a -> templatise $ printreport [a]
|
|
,dir "print" $ templatise $ printreport []
|
|
,dir "register" $ withDataFn (look "a") $ \a -> templatise $ registerreport [a]
|
|
,dir "register" $ templatise $ registerreport []
|
|
,dir "balance" $ withDataFn (look "a") $ \a -> templatise $ balancereport [a]
|
|
,dir "balance" $ templatise $ balancereport []
|
|
]
|
|
printreport apats = showLedgerTransactions opts (apats ++ args) l
|
|
registerreport apats = showRegisterReport opts (apats ++ args) l
|
|
balancereport [] = showBalanceReport opts args l
|
|
balancereport apats = showBalanceReport opts (apats ++ args) l'
|
|
where l' = cacheLedger apats (rawledger l) -- re-filter by account pattern each time
|
|
|
|
templatise :: String -> ServerPartT IO Response
|
|
templatise s = do
|
|
r <- askRq
|
|
return $ setHeader "Content-Type" "text/html" $ toResponse $ maintemplate r s
|
|
|
|
maintemplate :: Request -> String -> String
|
|
maintemplate r = printf (unlines
|
|
["<div style=float:right>"
|
|
,"<form action=%s>search: <input name=a value=%s></form>"
|
|
,"</div>"
|
|
,"<div align=center style=width:100%%>"
|
|
," <a href=balance>balance</a>"
|
|
,"|"
|
|
," <a href=register>register</a>"
|
|
,"|"
|
|
," <a href=print>print</a>"
|
|
,"</div>"
|
|
,"<pre>%s</pre>"
|
|
])
|
|
(dropWhile (=='/') $ rqUri r)
|
|
(fromMaybe "" $ queryValue "a" r)
|
|
|
|
queryValues :: String -> Request -> [String]
|
|
queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r
|
|
|
|
queryValue :: String -> Request -> Maybe String
|
|
queryValue q r = case filter ((==q).fst) $ rqInputs r of
|
|
[] -> Nothing
|
|
is -> Just $ B.unpack $ inputValue $ snd $ head is
|
|
|
|
-- | Attempt to open a web browser on the given url, all platforms.
|
|
openBrowserOn :: String -> IO ExitCode
|
|
openBrowserOn u = trybrowsers browsers u
|
|
where
|
|
trybrowsers (b:bs) u = do
|
|
e <- system $ printf "%s %s" b u
|
|
case e of
|
|
ExitSuccess -> return ExitSuccess
|
|
ExitFailure _ -> trybrowsers bs u
|
|
trybrowsers [] u = do
|
|
putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers
|
|
putStrLn $ printf "Please open your browser and visit %s" u
|
|
return $ ExitFailure 127
|
|
browsers | os=="darwin" = ["open"]
|
|
| os=="mingw32" = ["firefox","safari","opera","iexplore"]
|
|
| otherwise = ["sensible-browser","firefox"]
|
|
-- jeffz: write a ffi binding for it using the Win32 package as a basis
|
|
-- start by adding System/Win32/Shell.hsc and follow the style of any
|
|
-- other module in that directory for types, headers, error handling and
|
|
-- what not.
|
|
-- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);
|
|
-- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);
|
|
|