web: --serve-api disables server-side UI; startup logging cleanups

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

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

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")
 

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")
 

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

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

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")
 

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")
 

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
+  _ <- printf "Serving web %s on %s:%d with base url %s\n"
-  if serve_ opts
+         (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 "This server will exit after 2m with no browser windows open (or press ctrl-c)"
-      putStrLn "Web app will auto-exit after a few minutes with no browsers (or press ctrl-c)"
+      putStrLn "Opening web browser..."
       hFlush stdout
+      -- exits after 2m of inactivity (hardcoded)
       Network.Wai.Handler.Launch.runHostPortUrl h p "" app
 

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

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