From c3da82043b7a7be3cf716a468adc5de2adebf883 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Fri, 16 Aug 2019 23:55:56 -0700 Subject: [PATCH] web: --serve-api disables server-side UI; startup logging cleanups --- hledger-web/Hledger/Web/Application.hs | 4 ++-- hledger-web/Hledger/Web/Foundation.hs | 11 +++++++++-- hledger-web/Hledger/Web/Handler/AddR.hs | 6 +++++- hledger-web/Hledger/Web/Handler/EditR.hs | 5 ++++- hledger-web/Hledger/Web/Handler/JournalR.hs | 1 + hledger-web/Hledger/Web/Handler/MiscR.hs | 6 +++++- hledger-web/Hledger/Web/Handler/RegisterR.hs | 1 + hledger-web/Hledger/Web/Handler/UploadR.hs | 5 ++++- hledger-web/Hledger/Web/Main.hs | 10 ++++++---- hledger-web/Hledger/Web/WebOptions.hs | 8 +++++++- hledger-web/hledger-web.m4.md | 8 ++++++++ 11 files changed, 52 insertions(+), 13 deletions(-) diff --git a/hledger-web/Hledger/Web/Application.hs b/hledger-web/Hledger/Web/Application.hs index 3cd78dd5e..aa3a9cd9a 100644 --- a/hledger-web/Hledger/Web/Application.hs +++ b/hledger-web/Hledger/Web/Application.hs @@ -23,7 +23,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_)) +import Hledger.Web.WebOptions (WebOpts(serve_,serve_api_)) -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -41,7 +41,7 @@ makeApplication opts' j' conf' = do logWare <$> toWaiApp foundation where logWare | development = logStdoutDev - | serve_ opts' = logStdout + | serve_ opts' || serve_api_ opts' = logStdout | otherwise = id makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App diff --git a/hledger-web/Hledger/Web/Foundation.hs b/hledger-web/Hledger/Web/Foundation.hs index 67dd03bbb..1fec198a0 100644 --- a/hledger-web/Hledger/Web/Foundation.hs +++ b/hledger-web/Hledger/Web/Foundation.hs @@ -16,7 +16,7 @@ module Hledger.Web.Foundation where -import Control.Monad (join) +import Control.Monad (join, when) import qualified Data.ByteString.Char8 as BC import Data.Traversable (for) import Data.IORef (IORef, readIORef, writeIORef) @@ -96,7 +96,9 @@ type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) instance Yesod App where approot = ApprootMaster $ appRoot . settings - makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 ".hledger-web_client_session_key.aes" + makeSessionBackend _ = + let sessionexpirysecs = 120 + in Just <$> defaultClientSessionBackend sessionexpirysecs ".hledger-web_client_session_key.aes" defaultLayout widget = do master <- getYesod @@ -204,6 +206,11 @@ getViewData = do Right c -> pure [c] return VD {opts, today, j, q, m, qopts, caps} +checkServerSideUiEnabled :: Handler () +checkServerSideUiEnabled = do + VD{opts=WebOpts{serve_api_}} <- getViewData + when serve_api_ $ permissionDenied "server-side UI is disabled due to --serve-api" + -- | Find out if the sidebar should be visible. Show it, unless there is a -- showsidebar cookie set to "0", or a ?sidebar=0 query parameter. shouldShowSidebar :: Handler Bool diff --git a/hledger-web/Hledger/Web/Handler/AddR.hs b/hledger-web/Hledger/Web/Handler/AddR.hs index f0f4d3e2a..7364422ce 100644 --- a/hledger-web/Hledger/Web/Handler/AddR.hs +++ b/hledger-web/Hledger/Web/Handler/AddR.hs @@ -24,10 +24,13 @@ import Hledger.Web.WebOptions (WebOpts(..)) import Hledger.Web.Widget.AddForm (addForm) getAddR :: Handler () -getAddR = postAddR +getAddR = do + checkServerSideUiEnabled + postAddR postAddR :: Handler () postAddR = do + checkServerSideUiEnabled VD{caps, j, today} <- getViewData when (CapAdd `notElem` caps) (permissionDenied "Missing the 'add' capability") @@ -58,6 +61,7 @@ postAddR = do -- The web form handler above should probably use PUT as well. putAddR :: Handler RepJson putAddR = do + checkServerSideUiEnabled VD{caps, j, opts} <- getViewData when (CapAdd `notElem` caps) (permissionDenied "Missing the 'add' capability") diff --git a/hledger-web/Hledger/Web/Handler/EditR.hs b/hledger-web/Hledger/Web/Handler/EditR.hs index 8c9eed333..5bf2ca4e8 100644 --- a/hledger-web/Hledger/Web/Handler/EditR.hs +++ b/hledger-web/Hledger/Web/Handler/EditR.hs @@ -23,10 +23,13 @@ editForm f txt = fs = FieldSettings "text" mzero mzero mzero [("class", "form-control"), ("rows", "25")] getEditR :: FilePath -> Handler () -getEditR = postEditR +getEditR f = do + checkServerSideUiEnabled + postEditR f postEditR :: FilePath -> Handler () postEditR f = do + checkServerSideUiEnabled VD {caps, j} <- getViewData when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") diff --git a/hledger-web/Hledger/Web/Handler/JournalR.hs b/hledger-web/Hledger/Web/Handler/JournalR.hs index c715312f0..7effc05f7 100644 --- a/hledger-web/Hledger/Web/Handler/JournalR.hs +++ b/hledger-web/Hledger/Web/Handler/JournalR.hs @@ -17,6 +17,7 @@ import Hledger.Web.Widget.Common (accountQuery, mixedAmountAsHtml) -- | The formatted journal view, with sidebar. getJournalR :: Handler Html getJournalR = do + checkServerSideUiEnabled VD{caps, j, m, opts, qopts, today} <- getViewData when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") let title = case inAccount qopts of diff --git a/hledger-web/Hledger/Web/Handler/MiscR.hs b/hledger-web/Hledger/Web/Handler/MiscR.hs index 2b4656704..fe04c74ac 100644 --- a/hledger-web/Hledger/Web/Handler/MiscR.hs +++ b/hledger-web/Hledger/Web/Handler/MiscR.hs @@ -30,10 +30,13 @@ import Hledger.Web.Import import Hledger.Web.Widget.Common (journalFile404) getRootR :: Handler Html -getRootR = redirect JournalR +getRootR = do + checkServerSideUiEnabled + redirect JournalR getManageR :: Handler Html getManageR = do + checkServerSideUiEnabled VD{caps, j} <- getViewData when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") defaultLayout $ do @@ -42,6 +45,7 @@ getManageR = do getDownloadR :: FilePath -> Handler TypedContent getDownloadR f = do + checkServerSideUiEnabled VD{caps, j} <- getViewData when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") (f', txt) <- journalFile404 f j diff --git a/hledger-web/Hledger/Web/Handler/RegisterR.hs b/hledger-web/Hledger/Web/Handler/RegisterR.hs index 907e51419..3d2292001 100644 --- a/hledger-web/Hledger/Web/Handler/RegisterR.hs +++ b/hledger-web/Hledger/Web/Handler/RegisterR.hs @@ -22,6 +22,7 @@ import Hledger.Web.Widget.Common (accountQuery, mixedAmountAsHtml) -- | The main journal/account register view, with accounts sidebar. getRegisterR :: Handler Html getRegisterR = do + checkServerSideUiEnabled VD{caps, j, m, opts, qopts, today} <- getViewData when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") diff --git a/hledger-web/Hledger/Web/Handler/UploadR.hs b/hledger-web/Hledger/Web/Handler/UploadR.hs index c7d02d673..241c07d1d 100644 --- a/hledger-web/Hledger/Web/Handler/UploadR.hs +++ b/hledger-web/Hledger/Web/Handler/UploadR.hs @@ -27,10 +27,13 @@ uploadForm f = fs = FieldSettings "file" Nothing (Just "file") (Just "file") [] getUploadR :: FilePath -> Handler () -getUploadR = postUploadR +getUploadR f = do + checkServerSideUiEnabled + postUploadR f postUploadR :: FilePath -> Handler () postUploadR f = do + checkServerSideUiEnabled VD {caps, j} <- getViewData when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability") diff --git a/hledger-web/Hledger/Web/Main.hs b/hledger-web/Hledger/Web/Main.hs index 4b5321620..c3173d103 100644 --- a/hledger-web/Hledger/Web/Main.hs +++ b/hledger-web/Hledger/Web/Main.hs @@ -69,16 +69,18 @@ web opts j = do } app <- makeApplication opts j' appconfig -- XXX would like to allow a host name not just an IP address here - _ <- printf "Starting web app on IP address %s port %d with base url %s\n" h p u - if serve_ opts + _ <- printf "Serving web %s on %s:%d with base url %s\n" + (if serve_api_ opts then "API" else "UI and API" :: String) h p u + if serve_ opts || serve_api_ opts then do putStrLn "Press ctrl-c to quit" hFlush stdout let warpsettings = setHost (fromString h) (setPort p defaultSettings) Network.Wai.Handler.Warp.runSettings warpsettings app else do - putStrLn "Starting web browser..." - putStrLn "Web app will auto-exit after a few minutes with no browsers (or press ctrl-c)" + 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.runHostPortUrl h p "" app diff --git a/hledger-web/Hledger/Web/WebOptions.hs b/hledger-web/Hledger/Web/WebOptions.hs index a222ac011..ef5ac102f 100644 --- a/hledger-web/Hledger/Web/WebOptions.hs +++ b/hledger-web/Hledger/Web/WebOptions.hs @@ -31,6 +31,10 @@ webflags = ["serve", "server"] (setboolopt "serve") "serve and log requests, don't browse or auto-exit" + , flagNone + ["serve-api"] + (setboolopt "serve-api") + "like --serve, but serve only the JSON web API, without the server-side web UI" , flagReq ["host"] (\s opts -> Right $ setopt "host" s opts) @@ -89,6 +93,7 @@ webmode = -- hledger-web options, used in hledger-web and above data WebOpts = WebOpts { serve_ :: Bool + , serve_api_ :: Bool , host_ :: String , port_ :: Int , base_url_ :: String @@ -99,7 +104,7 @@ data WebOpts = WebOpts } deriving (Show) defwebopts :: WebOpts -defwebopts = WebOpts def def def def def [CapView, CapAdd] Nothing def +defwebopts = WebOpts def def def def def def [CapView, CapAdd] Nothing def instance Default WebOpts where def = defwebopts @@ -120,6 +125,7 @@ rawOptsToWebOpts rawopts = return defwebopts { serve_ = boolopt "serve" rawopts + , serve_api_ = boolopt "serve-api" rawopts , host_ = h , port_ = p , base_url_ = b diff --git a/hledger-web/hledger-web.m4.md b/hledger-web/hledger-web.m4.md index 4bc5c2f07..3a4dc237f 100644 --- a/hledger-web/hledger-web.m4.md +++ b/hledger-web/hledger-web.m4.md @@ -64,6 +64,9 @@ as shown in the synopsis above. `--serve` : serve and log requests, don't browse or auto-exit +`--serve-api` +: like --serve, but serve only the JSON web API, without the server-side web UI + `--host=IPADDR` : listen on this IP address (default: 127.0.0.1) @@ -108,6 +111,8 @@ browser window, and will exit after two minutes of inactivity (no requests and no browser windows viewing it). With `--serve`, it just runs the web app without exiting, and logs requests to the console. +With `--serve-api`, only the JSON web api (see below) is served, +with the usual HTML server-side web UI disabled. By default the server listens on IP address 127.0.0.1, accessible only to local requests. You can use `--host` to change this, eg `--host 0.0.0.0` to listen on all configured addresses. @@ -217,6 +222,9 @@ And here's how to test adding that with curl: $ curl -s http://127.0.0.1:5000/add -X PUT -H 'Content-Type: application/json' --data-binary @txn.pretty.json; echo ``` +By default, both the server-side HTML UI and the JSON API are served. +Running with `--serve-api` disables the former, useful if you only want to serve the API. + _man_({{ # ENVIRONMENT