slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

webyesod: drop --host, add --base-url option for base url and tcp port independence

Browse Source
This commit is contained in:
Simon Michael 2010-07-08 18:47:32 +00:00
parent 18bf123eae
commit 3865759bbd
2 changed files with 15 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Hledger/Cli/Commands/Web.hs
View File

@ -31,35 +31,35 @@ import Paths_hledger (getDataFileName)
defhost = "localhost" defhost = "localhost"
defport = 5000 defport = 5000
defbaseurl = printf "http://%s:%d" defhost defport :: String
browserstartdelay = 100000 -- microseconds browserstartdelay = 100000 -- microseconds
hledgerurl = "http://hledger.org" hledgerurl = "http://hledger.org"
manualurl = hledgerurl++"/MANUAL.html" manualurl = hledgerurl++"/MANUAL.html"
web :: [Opt] -> [String] -> Journal -> IO () web :: [Opt] -> [String] -> Journal -> IO ()
web opts args j = do web opts args j = do
let host = fromMaybe defhost $ hostFromOpts opts let baseurl = fromMaybe defbaseurl $ baseUrlFromOpts opts
port = fromMaybe defport $ portFromOpts opts port = fromMaybe defport $ portFromOpts opts
url = printf "http://%s:%d" host port :: String unless (Debug `elem` opts) $ forkIO (browser baseurl) >> return ()
unless (Debug `elem` opts) $ forkIO (browser url) >> return () server baseurl port opts args j
server url port opts args j
browser :: String -> IO () browser :: String -> IO ()
browser url = do browser baseurl = do
putStrLn "starting web browser" putStrLn "starting web browser"
threadDelay browserstartdelay threadDelay browserstartdelay
openBrowserOn url openBrowserOn baseurl
return () return ()
server :: String -> Int -> [Opt] -> [String] -> Journal -> IO () server :: String -> Int -> [Opt] -> [String] -> Journal -> IO ()
server url port opts args j = do server baseurl port opts args j = do
printf "starting web server at %s\n" url printf "starting web server on port %d with base url %s\n" port baseurl
fp <- getDataFileName "web" fp <- getDataFileName "web"
let app = HledgerWebApp{ let app = HledgerWebApp{
appOpts=opts appOpts=opts
,appArgs=args ,appArgs=args
,appJournal=j ,appJournal=j
,appWebdir=fp ,appWebdir=fp
,appRoot=url ,appRoot=baseurl
} }
withStore "hledger" $ do withStore "hledger" $ do
putValue "hledger" "journal" j putValue "hledger" "journal" j

12
Hledger/Cli/Options.hs
View File

@ -82,8 +82,8 @@ options = [
,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary" ,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary"
,Option "Y" ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary" ,Option "Y" ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary"
#ifdef WEB #ifdef WEB
,Option "" ["host"] (ReqArg Host "HOST") "web: use hostname HOST rather than localhost" ,Option "" ["base-url"] (ReqArg BaseUrl "URL") "web: use this base url (default http://localhost:PORT)"
,Option "" ["port"] (ReqArg Port "N") "web: use tcp port N rather than 5000" ,Option "" ["port"] (ReqArg Port "N") "web: serve on tcp port N (default 5000)"
#endif #endif
,Option "h" ["help"] (NoArg Help) "show this help" ,Option "h" ["help"] (NoArg Help) "show this help"
,Option "V" ["version"] (NoArg Version) "show version information" ,Option "V" ["version"] (NoArg Version) "show version information"
@ -120,7 +120,7 @@ data Opt =
QuarterlyOpt | QuarterlyOpt |
YearlyOpt | YearlyOpt |
#ifdef WEB #ifdef WEB
Host {value::String} | BaseUrl {value::String} |
Port {value::String} | Port {value::String} |
#endif #endif
Help | Help |
@ -225,9 +225,9 @@ displayExprFromOpts opts = listtomaybe $ optValuesForConstructor Display opts
listtomaybe vs = Just $ last vs listtomaybe vs = Just $ last vs
#ifdef WEB #ifdef WEB
-- | Get the value of the (last) host option, if any. -- | Get the value of the (last) baseurl option, if any.
hostFromOpts :: [Opt] -> Maybe String baseUrlFromOpts :: [Opt] -> Maybe String
hostFromOpts opts = listtomaybe $ optValuesForConstructor Host opts baseUrlFromOpts opts = listtomaybe $ optValuesForConstructor BaseUrl opts
where where
listtomaybe [] = Nothing listtomaybe [] = Nothing
listtomaybe vs = Just $ last vs listtomaybe vs = Just $ last vs