From 7aae0d9595d27627c93bf099aa8f913f75fe3082 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sat, 8 Mar 2025 12:41:03 -1000 Subject: [PATCH] imp:web: add an explicit --serve-browse flag, for consistency --- hledger-web/Hledger/Web/App.hs | 4 +-- hledger-web/Hledger/Web/Application.hs | 4 +-- hledger-web/Hledger/Web/Main.hs | 21 +++++++------- hledger-web/Hledger/Web/WebOptions.hs | 38 ++++++++++++++++++-------- hledger-web/hledger-web.m4.md | 13 +++++---- 5 files changed, 48 insertions(+), 32 deletions(-) diff --git a/hledger-web/Hledger/Web/App.hs b/hledger-web/Hledger/Web/App.hs index e55162b52..93cfec3fa 100644 --- a/hledger-web/Hledger/Web/App.hs +++ b/hledger-web/Hledger/Web/App.hs @@ -269,8 +269,8 @@ getViewData = do checkServerSideUiEnabled :: Handler () checkServerSideUiEnabled = do - VD{opts=WebOpts{serve_api_}} <- getViewData - when serve_api_ $ + VD{opts=WebOpts{server_mode_}} <- getViewData + when (server_mode_ == ServeJson) $ -- this one gives 500 internal server error when called from defaultLayout: -- permissionDenied "server-side UI is disabled due to --serve-api" sendResponseStatus status403 ("server-side UI is disabled due to --serve-api" :: Text) diff --git a/hledger-web/Hledger/Web/Application.hs b/hledger-web/Hledger/Web/Application.hs index 9a0d7fe32..037de01f1 100644 --- a/hledger-web/Hledger/Web/Application.hs +++ b/hledger-web/Hledger/Web/Application.hs @@ -29,7 +29,7 @@ import Hledger.Web.Handler.UploadR import Hledger.Web.Handler.JournalR import Hledger.Web.Handler.RegisterR import Hledger.Web.Import -import Hledger.Web.WebOptions (WebOpts(serve_,serve_api_), corsPolicy) +import Hledger.Web.WebOptions (ServerMode(..), WebOpts(server_mode_), corsPolicy) -- mkYesodDispatch creates our YesodDispatch instance. -- It complements the mkYesodData call in App.hs, @@ -47,7 +47,7 @@ makeApplication opts' j' conf' = do (logWare . (corsPolicy opts')) <$> toWaiApp app where logWare | development = logStdoutDev - | serve_ opts' || serve_api_ opts' = logStdout + | server_mode_ opts' `elem` [Serve, ServeJson] = logStdout | otherwise = id makeApp :: AppConfig DefaultEnv Extra -> WebOpts -> IO App diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index 1a9faf857..ee1274433 100644 --- a/hledger-web/Hledger/Web/Main.hs +++ b/hledger-web/Hledger/Web/Main.hs @@ -105,8 +105,9 @@ web opts j = do -- show configuration let - services | serve_api_ opts = "json API" - | otherwise = "web UI and json API" + services + | server_mode_ opts == ServeJson = "json API" + | otherwise = "web UI and json API" prettyip ip | ip == "127.0.0.1" = ip ++ " (local access)" | ip == "0.0.0.0" = ip ++ " (all interfaces)" @@ -121,8 +122,15 @@ web opts j = do Nothing -> pure () -- start server and maybe browser - if serve_ opts || serve_api_ opts + if server_mode_ opts == ServeBrowse then do + putStrLn "This server will exit after 2m with no browser windows open (or press ctrl-c)" + putStrLn "Opening web browser..." + hFlush stdout + -- exits after 2m of inactivity (hardcoded) + Network.Wai.Handler.Launch.runHostPortFullUrl h p u app + + else do putStrLn "Press ctrl-c to quit" hFlush stdout let warpsettings = setHost (fromString h) (setPort p defaultSettings) @@ -149,10 +157,3 @@ web opts j = do Nothing -> Network.Wai.Handler.Warp.runSettings warpsettings app - else do - putStrLn "This server will exit after 2m with no browser windows open (or press ctrl-c)" - putStrLn "Opening web browser..." - hFlush stdout - -- exits after 2m of inactivity (hardcoded) - Network.Wai.Handler.Launch.runHostPortFullUrl h p u app - diff --git a/hledger-web/Hledger/Web/WebOptions.hs b/hledger-web/Hledger/Web/WebOptions.hs index e445b7938..bbf7850e4 100644 --- a/hledger-web/Hledger/Web/WebOptions.hs +++ b/hledger-web/Hledger/Web/WebOptions.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Hledger.Web.WebOptions where @@ -54,13 +55,17 @@ prognameandversion = webflags :: [Flag RawOpts] webflags = [ flagNone + ["serve-browse"] + (setboolopt "serve-browse") + (serveprefix ++ "serve the web UI and JSON API, and open a browser, and exit if inactive for 2m (default)") + , flagNone ["serve"] (setboolopt "serve") - "serve and log requests, don't browse or auto-exit" + (serveprefix ++ "just serve the web UI and JSON API") , flagNone ["serve-api"] (setboolopt "serve-api") - "like --serve, but serve only the JSON web API, not the web UI" + (serveprefix ++ "just serve the JSON API") , flagReq ["allow"] (\s opts -> Right $ setopt "allow" s opts) @@ -85,7 +90,7 @@ webflags = ["socket"] (\s opts -> Right $ setopt "socket" s opts) "SOCKET" - "listen on the given unix socket instead of an IP address and port (unix only; implies --serve)" + "listen on the given unix socket instead of an IP address and port (only on unix)" , flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) @@ -102,6 +107,8 @@ webflags = (setboolopt "test") "run hledger-web's tests and exit. hspec test runner args may follow a --, eg: hledger-web --test -- --help" ] + where + serveprefix = "" webmode :: Mode RawOpts webmode = @@ -116,16 +123,17 @@ webmode = { groupUnnamed = webflags , groupHidden = hiddenflags ++ - [flagNone ["server"] (setboolopt "serve") "old flag, use --serve instead" + [flagNone ["server"] (setboolopt "serve") "old flag, use --serve instead"] , groupNamed = mkgeneralflagsgroups1 helpflags } , modeHelpSuffix = [] } +data ServerMode = ServeBrowse | Serve | ServeJson deriving (Show, Eq) + -- hledger-web options, used in hledger-web and above data WebOpts = WebOpts - { serve_ :: !Bool - , serve_api_ :: !Bool + { server_mode_ :: !ServerMode , cors_ :: !(Maybe String) , host_ :: !String , port_ :: !Int @@ -138,8 +146,7 @@ data WebOpts = WebOpts defwebopts :: WebOpts defwebopts = WebOpts - { serve_ = False - , serve_api_ = False + { server_mode_ = ServeBrowse , cors_ = Nothing , host_ = "" , port_ = def @@ -174,10 +181,7 @@ rawOptsToWebOpts rawopts = Left err -> error' ("Unknown access level: " ++ err) -- PARTIAL: return defwebopts - { serve_ = case sock of - Just _ -> True - Nothing -> boolopt "serve" rawopts - , serve_api_ = boolopt "serve-api" rawopts + { server_mode_ = servermodeopt rawopts , cors_ = maybestringopt "cors" rawopts , host_ = h , port_ = p @@ -190,6 +194,16 @@ rawOptsToWebOpts rawopts = where stripTrailingSlash = reverse . dropWhile (== '/') . reverse -- yesod don't like it +servermodeopt :: RawOpts -> ServerMode +servermodeopt = + fromMaybe ServeBrowse . choiceopt parse + where + parse = \case + "serve-browse" -> Just ServeBrowse + "serve" -> Just Serve + "serve-api" -> Just ServeJson + _ -> Nothing + checkWebOpts :: WebOpts -> WebOpts checkWebOpts wopts@WebOpts{..} | not $ null base_url_ || "http://" `isPrefixOf` base_url_ || "https://" `isPrefixOf` base_url_ = diff --git a/hledger-web/hledger-web.m4.md b/hledger-web/hledger-web.m4.md index bfd43ca63..6dab89b5b 100644 --- a/hledger-web/hledger-web.m4.md +++ b/hledger-web/hledger-web.m4.md @@ -50,14 +50,15 @@ Like hledger, it _inputfileswithptr_ hledger-web can be run in three modes: -- Transient mode (the default): - your default web browser will be opened to show the app if possible, - and the app exits automatically after two minutes of inactivity - (no requests received and no open browser windows viewing it). +- `--serve-browse` mode (the default): + the app serves the web UI and JSON API, + and opens your default web browser to show the app if possible, + and exits automatically after two minutes of inactivity + (with no requests received and no open browser windows viewing it). -- With `--serve`: the app runs without stopping, and without opening a browser. +- `--serve`: the app just serves the web UI and JSON API. -- With `--serve-api`: only the JSON API is served. +- `--serve-api`: the app just serves the JSON API. In all cases hledger-web runs as a foreground process, logging requests to stdout.