move openBrowserOn to Utils
This commit is contained in:
parent
472b65c5ab
commit
1c9eb60a04
@ -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>
|
|
||||||
filter by: <input name=a size=30 value=\"%s\">
|
|
||||||
reporting period: <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);
|
|
||||||
|
|
||||||
|
|||||||
26
Utils.hs
26
Utils.hs
@ -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);
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user