bin: Introduce --base-path argument for web-dev subcommand. HEAD main

* bin/tissue (tissue-web-dev): Introduce --base-path argument.
* tissue/web/dev.scm (handler, start-dev-web-server): Add base-path
argument.
* tissue/web/server.scm (rebase-uri-path): Export.

3 files changed, 51 insertions, 35 deletions

diff --git a/bin/tissue b/bin/tissue
index 2b5ab7d..1e45d89 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -323,6 +323,7 @@ Serve website and issues of current repository.
 
   --port=PORT       run web server listening on PORT (default: 8080)
   --listen-repl=P   run REPL server listening on port or path P
+  --base-path=PATH  serve website at PATH
 "
              (command-line-program)))
     (args
@@ -333,13 +334,20 @@ Serve website and issues of current repository.
                                           (lambda (opt name arg result)
                                             (acons 'port
                                                    (string->number arg)
+                                                   result)))
+                                  (option '(#\b "base-path")
+                                          #t #f
+                                          (lambda (opt name arg result)
+                                            (acons 'base-path arg
                                                    result))))
                             invalid-option
                             unrecognized-argument
-                            '((port . 8080)))))
+                            '((port . 8080)
+                              (base-path . "/")))))
        (when (assq-ref args 'listen-repl)
          (start-repl (assq-ref args 'listen-repl)))
        (start-dev-web-server (assq-ref args 'port)
+                             (assq-ref args 'base-path)
                              %xapian-index load-config)))))
 
 (define (print-usage)
diff --git a/tissue/web/dev.scm b/tissue/web/dev.scm
index 5ca7d16..39a090e 100644
--- a/tissue/web/dev.scm
+++ b/tissue/web/dev.scm
@@ -1,5 +1,5 @@
 ;;; tissue --- Text based issue tracker
-;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022, 2023, 2025 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of tissue.
 ;;;
@@ -32,47 +32,54 @@
   #:use-module (tissue web static)
   #:export (start-dev-web-server))
 
-(define (handler request body xapian-index project-thunk)
+(define (handler request body base-path xapian-index project-thunk)
   "Handle web @var{request} with @var{body} and return two values---the
 response headers and body. See @code{start-dev-web-server} for
-documentation of @var{xapian-index} and @var{project-thunk}."
+documentation of @var{base-path}, @var{xapian-index} and
+@var{project-thunk}."
   ;; The project configuration could have changed between requests and
   ;; we want to read the latest configuration on each request. So, we
   ;; require a thunk that loads the project configuration, rather than
   ;; the project configuration itself.
-  (let ((project (project-thunk))
-        (path (uri-path (request-uri request))))
+  (let ((project (project-thunk)))
     (log-request request)
-    (cond
-     ;; Files
-     ((any (lambda (web-file)
-             (cond
-              ((find (cut string=?
-                          (string-append "/" (file-name web-file))
-                          <>)
-                     (try-paths path))
-               => (cut file <> (file-writer web-file)))
-              (else #f)))
-           (tissue-configuration-web-files project))
-      => (lambda (file)
-           (values `((content-type . ,(mime-type-for-extension
-                                       (file-name-extension (file-name file)))))
-                   (call-with-values open-bytevector-output-port
-                     (lambda (port get-bytevector)
-                       ((file-writer file) port)
-                       (get-bytevector))))))
-     ;; Search page. We look for the search page only after files
-     ;; because we want to let files shadow the search page if
-     ;; necessary.
-     ((member path (list "/" "/search"))
-      (search-handler request body xapian-index project))
-     ;; Not found
-     (else
-      (404-response request)))))
+    (unless (string-prefix? base-path (uri-path (request-uri request)))
+      (404-response request))
+    ;; If we simply used string-remove-prefix here, we would have
+    ;; trouble with trailing slashes.
+    (let ((path (rebase-uri-path (uri-path (request-uri request))
+                                 base-path)))
+      (cond
+       ;; Files
+       ((any (lambda (web-file)
+               (cond
+                ((find (cut string=?
+                            (string-append "/" (file-name web-file))
+                            <>)
+                       (try-paths path))
+                 => (cut file <> (file-writer web-file)))
+                (else #f)))
+             (tissue-configuration-web-files project))
+        => (lambda (file)
+             (values `((content-type . ,(mime-type-for-extension
+                                         (file-name-extension (file-name file)))))
+                     (call-with-values open-bytevector-output-port
+                       (lambda (port get-bytevector)
+                         ((file-writer file) port)
+                         (get-bytevector))))))
+       ;; Search page. We look for the search page only after files
+       ;; because we want to let files shadow the search page if
+       ;; necessary.
+       ((member path (list "/" "/search"))
+        (search-handler request body xapian-index project))
+       ;; Not found
+       (else
+        (404-response request))))))
 
-(define (start-dev-web-server port xapian-index project-thunk)
+(define (start-dev-web-server port base-path xapian-index project-thunk)
   "Start development web server listening on
-@var{port}. @var{xapian-index} is the path to the Xapian index to
+@var{port}. @var{base-path} is the path under which the website should
+be served. @var{xapian-index} is the path to the Xapian index to
 search in. @var{project} is a thunk that returns a
 @code{<tissue-configuration>} object describing the project."
   (format (current-error-port)
@@ -81,6 +88,6 @@ search in. @var{project} is a thunk that returns a
   ;; so as to support live hacking.
   (run-server (cut (module-ref (resolve-module '(tissue web dev))
                                'handler)
-                   <> <> xapian-index project-thunk)
+                   <> <> base-path xapian-index project-thunk)
               'http
               (list #:port port)))
diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index afb259f..e74c7ae 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.scm
@@ -49,6 +49,7 @@
             try-paths
             404-response
             search-handler
+            rebase-uri-path
             start-web-server))
 
 (define (log-request request)