From fa8d223858d5bea118ffeca0e27990305bff1a00 Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Thu, 18 Jul 2024 10:12:40 +0100
Subject: [PATCH] imp: web: guess a more robust base url when --base-url is not
 used

A followup to #2099, #2100 and #2127. Now relative links to js/css
resources will use the same hostname etc. the main page was requested
from, making them work better when accessed via multiple IP
addresses/hostnames without an explicit --base-url setting.
---
 hledger-web/Hledger/Web/App.hs        | 22 ++++++++++------------
 hledger-web/Hledger/Web/WebOptions.hs |  4 ++++
 2 files changed, 14 insertions(+), 12 deletions(-)

diff --git a/hledger-web/Hledger/Web/App.hs b/hledger-web/Hledger/Web/App.hs
index ef3488362..e55162b52 100644
--- a/hledger-web/Hledger/Web/App.hs
+++ b/hledger-web/Hledger/Web/App.hs
@@ -52,6 +52,7 @@ import Hledger.Web.Settings (Extra(..), widgetFile)
 import Hledger.Web.Settings.StaticFiles
 import Hledger.Web.WebOptions
 import Hledger.Web.Widget.Common (balanceReportAsHtml)
+import Data.List (isPrefixOf)
 
 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@@ -104,19 +105,16 @@ type Form a = Html -> MForm Handler (FormResult a, Widget)
 instance Yesod App where
 
   -- Configure the app root, AKA base url, which is prepended to relative hyperlinks.
-  -- Broadly, we'd like this:
-  -- 1. when --base-url has been specified, use that;
-  -- 2. otherwise, guess it from request headers, which helps us respond from the
-  --    same hostname/IP address when hledger-web is accessible at multiple IPs;
+  -- 1. when a --base-url was specified, use that
+  -- 2. otherwise, guess it from request headers, which helps us respond from the same hostname/IP address when accessible via multiple IPs
   -- 3. otherwise, leave it empty (relative links stay relative).
-  -- But it's hard to see how to achieve this.
-  -- For now we do (I believe) 1 or 3, with 2 unfortunately not supported.
-  -- Issues include: #2099, #2100, #2127
-  approot =
-    -- ApprootRelative
-    -- ApprootMaster $ appRoot . settings
-    -- guessApprootOr (ApprootMaster $ appRoot . settings)
-    ApprootMaster $ \(App{settings=AppConfig{appRoot=r}, appOpts=WebOpts{base_url_=bu}}) -> if null bu then r else T.pack bu
+  -- Past issues: #2099, #2100, #2127, #hledger-2024-07-18
+  approot
+    | hasbaseurl = ApprootMaster (T.pack . base_url_ . appOpts)
+    | otherwise  = guessApprootOr (ApprootMaster (appRoot . settings))
+    where
+      hasbaseurl = any ("--base-url" `isPrefixOf`) progArgs
+        -- needs unsafePerformIO; does not detect abbreviations like --base
 
   makeSessionBackend _ = do
     hledgerdata <- getXdgDirectory XdgCache "hledger"
diff --git a/hledger-web/Hledger/Web/WebOptions.hs b/hledger-web/Hledger/Web/WebOptions.hs
index 292bfa517..5a0375e1b 100644
--- a/hledger-web/Hledger/Web/WebOptions.hs
+++ b/hledger-web/Hledger/Web/WebOptions.hs
@@ -157,6 +157,10 @@ rawOptsToWebOpts rawopts =
     let
       h = fromMaybe defhost $ maybestringopt "host" rawopts
       p = fromMaybe defport $ maybeposintopt "port" rawopts
+      -- Always set a base-url, constructing it from host and port if not specified.
+      -- This will be used when opening a web browser, eg.
+      -- App.hs approot will use it if it was specified by --base-url,
+      -- otherwise it will infer a better one from the request, which browsers prefer.
       b = maybe (defbaseurl h p) stripTrailingSlash $ maybestringopt "base-url" rawopts
       sock = stripTrailingSlash <$> maybestringopt "socket" rawopts
       access =