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 module Commands.Web
@ -7,9 +7,6 @@ where
import Control.Concurrent import Control.Concurrent
import Happstack.Server import Happstack.Server
import Happstack.State.Control (waitForTermination) import Happstack.State.Control (waitForTermination)
import System.Cmd (system)
import System.Info (os)
import System.Exit
import Network.HTTP (urlEncode, urlDecode) import Network.HTTP (urlEncode, urlDecode)
import Text.XHtml hiding (dir) import Text.XHtml hiding (dir)
@ -19,7 +16,7 @@ import Commands.Balance
import Commands.Register import Commands.Register
import Commands.Print import Commands.Print
import Commands.Histogram import Commands.Histogram
import Utils (filterAndCacheLedgerWithOpts) import Utils (filterAndCacheLedgerWithOpts, openBrowserOn)
tcpport = 5000 tcpport = 5000
@ -31,11 +28,11 @@ web opts args l = do
then do then do
-- just run the server in the foreground -- just run the server in the foreground
putStrLn $ printf "starting web server on port %d in debug mode" tcpport 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 else do
-- start the server (in background, so we can..) then start the web browser -- start the server (in background, so we can..) then start the web browser
putStrLn $ printf "starting web server on port %d" tcpport 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" putStrLn "starting web browser"
openBrowserOn $ printf "http://localhost:%d/" tcpport openBrowserOn $ printf "http://localhost:%d/" tcpport
waitForTermination waitForTermination
@ -43,8 +40,8 @@ web opts args l = do
killThread tid killThread tid
putStrLn "shutdown complete" putStrLn "shutdown complete"
webHandlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response handlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response
webHandlers opts args l t = msum handlers opts args l t = msum
[ [
methodSP GET $ view showBalanceReport methodSP GET $ view showBalanceReport
,dir "balance" $ view showBalanceReport ,dir "balance" $ view showBalanceReport
@ -69,22 +66,6 @@ webHandlers opts args l t = msum
r <- askRq r <- askRq
return $ setHeader "Content-Type" "text/html" $ toResponse $ renderHtml $ hledgerview r a p s 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 :: Request -> String -> String -> String -> Html
hledgerview r a p' s = body << topbar r a p' +++ pre << s hledgerview r a p' s = body << topbar r a p' +++ pre << s
@ -130,26 +111,3 @@ navlinks _ a p' =
-- [] -> Nothing -- [] -> Nothing
-- is -> Just $ B.unpack $ inputValue $ snd $ head is -- 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 Options (Opt,ledgerFilePathFromOpts,optsToFilterSpec)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.IO 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 -- | 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 :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger
filterAndCacheLedgerWithOpts opts args = filterAndCacheLedger . optsToFilterSpec opts args 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);