move openBrowserOn to Utils

This commit is contained in:
Simon Michael 2009-06-28 21:06:07 +00:00
parent 472b65c5ab
commit 1c9eb60a04
2 changed files with 32 additions and 48 deletions

View File

@ -1,5 +1,5 @@
{-|
A happs-based web UI for hledger.
A server-side-html web UI using happstack.
-}
module Commands.Web
@ -7,9 +7,6 @@ where
import Control.Concurrent
import Happstack.Server
import Happstack.State.Control (waitForTermination)
import System.Cmd (system)
import System.Info (os)
import System.Exit
import Network.HTTP (urlEncode, urlDecode)
import Text.XHtml hiding (dir)
@ -19,7 +16,7 @@ import Commands.Balance
import Commands.Register
import Commands.Print
import Commands.Histogram
import Utils (filterAndCacheLedgerWithOpts)
import Utils (filterAndCacheLedgerWithOpts, openBrowserOn)
tcpport = 5000
@ -31,11 +28,11 @@ web opts args l = do
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} $ webHandlers opts args l t
simpleHTTP nullConf{port=tcpport} $ handlers opts args l t
else do
-- start the server (in background, so we can..) then start the web browser
putStrLn $ printf "starting web server on port %d" tcpport
tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ webHandlers opts args l t
tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ handlers opts args l t
putStrLn "starting web browser"
openBrowserOn $ printf "http://localhost:%d/" tcpport
waitForTermination
@ -43,8 +40,8 @@ web opts args l = do
killThread tid
putStrLn "shutdown complete"
webHandlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response
webHandlers opts args l t = msum
handlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response
handlers opts args l t = msum
[
methodSP GET $ view showBalanceReport
,dir "balance" $ view showBalanceReport
@ -69,22 +66,6 @@ webHandlers opts args l t = msum
r <- askRq
return $ setHeader "Content-Type" "text/html" $ toResponse $ renderHtml $ hledgerview r a p s
{-
<div style=\"float:right;text-align:right;\">
<form action=%s>
&nbsp; filter by:&nbsp;<input name=a size=30 value=\"%s\">
&nbsp; reporting period:&nbsp;<input name=p size=30 value=\"%s\">
%s
</form>
</div>
<div style=\"width:100%%; font-weight:bold;\">
<a href=balance%s>balance</a>
| <a href=register%s>register</a>
| <a href=print%s>print</a>
| <a href=histogram%s>histogram</a>
</div>
<pre>%s</pre>
-}
hledgerview :: Request -> String -> String -> String -> Html
hledgerview r a p' s = body << topbar r a p' +++ pre << s
@ -130,26 +111,3 @@ navlinks _ a p' =
-- [] -> 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" = ["start","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);

View File

@ -12,6 +12,9 @@ import Ledger
import Options (Opt,ledgerFilePathFromOpts,optsToFilterSpec)
import System.Directory (doesFileExist)
import System.IO
import System.Exit
import System.Cmd (system)
import System.Info (os)
-- | Parse the user's specified ledger file and run a hledger command on
@ -49,3 +52,26 @@ readLedgerWithOpts opts args f = do
filterAndCacheLedgerWithOpts :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger
filterAndCacheLedgerWithOpts opts args = filterAndCacheLedger . optsToFilterSpec opts args
-- | 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" = ["start","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);