mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 10:47:29 +03:00
web command now shows ledger/register/balance, starts browser
This commit is contained in:
parent
354c69dbcf
commit
cf0243201f
109
HappsCommand.hs
109
HappsCommand.hs
@ -1,14 +1,24 @@
|
||||
{-|
|
||||
|
||||
A happs-based web UI for hledger.
|
||||
|
||||
-}
|
||||
|
||||
module WebCommand
|
||||
where
|
||||
import qualified Data.Map as Map
|
||||
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 Text.StringTemplate as T
|
||||
import Codec.Compression.GZip (compress)
|
||||
import qualified Data.ByteString.Lazy.Char8 as B
|
||||
import Data.ByteString.UTF8 (fromString, toString)
|
||||
import HAppS.Server
|
||||
import System.Cmd (system)
|
||||
import System.Info (os)
|
||||
import System.Exit
|
||||
|
||||
import Ledger
|
||||
import Options
|
||||
import BalanceCommand
|
||||
@ -32,8 +42,91 @@ tcpport = 5000
|
||||
|
||||
web :: [Opt] -> [String] -> Ledger -> IO ()
|
||||
web opts args l = do
|
||||
putStrLn $ printf "starting hledger web server on port %d" tcpport
|
||||
simpleHTTP nullConf{port=tcpport} [
|
||||
method GET $ ok $ toResponse $ output
|
||||
]
|
||||
where output = showBalanceReport (opts++[SubTotal]) [] l
|
||||
putStrLn $ printf "starting web server on port %d" tcpport
|
||||
tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ handlers opts args l
|
||||
putStrLn "starting web browser"
|
||||
browseUrl $ printf "http://localhost:%s/print" (show tcpport)
|
||||
waitForTermination
|
||||
putStrLn "shutting down..."
|
||||
killThread tid
|
||||
putStrLn "shutdown complete"
|
||||
|
||||
template = "<div align=center style=width:100%%>" ++
|
||||
" <a href=print>ledger</a>" ++
|
||||
" | <a href=register>register</a>" ++
|
||||
" | <a href=balance>balance</a>" ++
|
||||
"</div>" ++
|
||||
"<pre>%s</pre>"
|
||||
|
||||
type Handler = ServerPart Response
|
||||
|
||||
handlers :: [Opt] -> [String] -> Ledger -> [Handler]
|
||||
handlers opts args l =
|
||||
[
|
||||
dir "print" [withRequest $ \r -> respond $ printreport r]
|
||||
, dir "register" [withRequest $ \r -> respond $ registerreport r]
|
||||
, dir "balance" [withRequest $ \r -> respond $ balancereport r]
|
||||
]
|
||||
where
|
||||
respond = ok . setContentType "text/html" . toResponse . (printf template :: String -> String)
|
||||
printreport r = showEntries opts (pats r ++ args) l
|
||||
registerreport r = showRegisterReport opts (pats r ++ args) l
|
||||
balancereport r = showBalanceReport (opts++[SubTotal]) (pats r ++ args) l
|
||||
pats r = as -- ++ if null ds then [] else ("--":ds)
|
||||
where (as,ds) = (queryValues "a" r, queryValues "d" 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.
|
||||
browseUrl :: String -> IO ExitCode
|
||||
browseUrl 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 -a firefox", "open"]
|
||||
| os=="mingw32" = ["firefox","safari","opera","iexplore"]
|
||||
| otherwise = ["firefox","sensible-browser"]
|
||||
-- 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);
|
||||
|
||||
withExpiresHeaders :: ServerPart Response -> ServerPart Response
|
||||
withExpiresHeaders sp = require getCacheTime $ \t -> [liftM (setHeader "Expires" $ formatDateTime "%a, %d %b %Y %T GMT" t) sp]
|
||||
|
||||
getCacheTime :: IO (Maybe UTCTime)
|
||||
getCacheTime = getCurrentTime >>= (return . Just . addMinutes 360)
|
||||
|
||||
addMinutes :: Int -> UTCTime -> UTCTime
|
||||
addMinutes n = addUTCTime (fromIntegral n)
|
||||
|
||||
formatDateTime :: String -> UTCTime -> String
|
||||
formatDateTime = formatTime defaultTimeLocale
|
||||
|
||||
setContentType :: String -> Response -> Response
|
||||
setContentType = setHeader "Content-Type"
|
||||
|
||||
setFilename :: String -> Response -> Response
|
||||
setFilename = setHeader "Content-Disposition" . \fname -> "attachment: filename=\"" ++ fname ++ "\""
|
||||
|
||||
gzipBinary :: Response -> Response
|
||||
gzipBinary r@(Response {rsBody = b}) = setHeader "Content-Encoding" "gzip" $ r {rsBody = compress b}
|
||||
|
||||
acceptsZip :: Request -> Bool
|
||||
acceptsZip req = isJust $ M.lookup (fromString "accept-encoding") (rqHeaders req)
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user