web: Allow hosting multiple projects at the same host.

tissue instances will most often be used with multiple projects. The
trouble of setting up separate DNS entries for each project is just
not worth the trouble. Hence, despite some loss of elegance and
simplicity, we make this concession. With this change, tissue
instances will resemble public-inbox instances in their URL structure.

However, larger projects may wish to keep the entire host to
themselves, particularly for branding reasons. To support such
projects, we must still allow single project hosts.

* tissue/web/server.scm (rebase-uri-path): New function.
(handler): Handle hosts and projects.
* bin/tissue (normalize-project): New function.
(normalize-host, tissue-pull): Adapt to new tissue.conf layout.

2 files changed, 87 insertions, 28 deletions

diff --git a/bin/tissue b/bin/tissue
index 1f91d48..2b5ab7d 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -252,23 +252,39 @@ port."
         (call-with-current-directory temporary-checkout
           load-config)))))
 
-(define (normalize-host state-directory host)
-  "Normalize @var{host} from @file{tissue.conf} adding in default and
+(define (normalize-project state-directory project)
+  "Normalize @var{project} from @file{tissue.conf} adding in default and
 extra parameters for convenient processing later on.
 @var{state-directory} is the tissue state directory."
-  (match-lambda
+  (match project
     ((name . parameters)
-     ;; Add repository directory, website directory, xapian directory
-     ;; settings for each host.
      (let ((repository-directory
             (string-append state-directory "/" name "/repository")))
        (cons name
-             `((project . ,(load-config-from-repository repository-directory))
+             `((base-path . ,(or (assq-ref parameters 'base-path)
+                                 (string-append "/" name)))
+               (project . ,(load-config-from-repository repository-directory))
                (repository-directory . ,repository-directory)
-               (website-directory . ,(string-append state-directory "/" name "/website"))
-               (xapian-directory . ,(string-append state-directory "/" name "/xapian"))
+               (website-directory . ,(string-append state-directory
+                                                    "/" name "/website"))
+               (xapian-directory . ,(string-append state-directory
+                                                   "/" name "/xapian"))
                ,@parameters))))))
 
+(define (normalize-host state-directory host)
+  "Normalize @var{host} from @file{tissue.conf} adding in default and
+extra parameters for convenient processing later on.
+@var{state-directory} is the tissue state directory."
+  (match host
+    ((host-name . host-parameters)
+     ;; Add repository directory, website directory, xapian directory
+     ;; settings for each host.
+     (cons host-name
+           `((projects
+              ,@(map (cut normalize-project state-directory <>)
+                     (assq-ref host-parameters 'projects)))
+             ,@host-parameters)))))
+
 (define tissue-web
   (match-lambda*
     (("--help")
@@ -455,7 +471,7 @@ HOSTNAME."
 (define tissue-pull
   (match-lambda*
     (("--help")
-     (format #t "Usage: ~a pull [OPTIONS] HOST
+     (format #t "Usage: ~a pull [OPTIONS] PROJECT
 Pull latest from upstream repositories.
 
   -C, --config=CONFIG-FILE    read configuration parameters from CONFIG-FILE
@@ -470,8 +486,8 @@ Pull latest from upstream repositories.
                                                       read)
                                                     result))))
                             invalid-option
-                            (lambda (host result)
-                              (acons 'host host result))
+                            (lambda (project result)
+                              (acons 'project project result))
                             (default-configuration))))
        (let ((state-directory (assq-ref args 'state-directory)))
          ;; Error out if state directory does not exist.
@@ -480,24 +496,27 @@ Pull latest from upstream repositories.
                    "State directory ~a does not exist.~%"
                    state-directory)
            (exit #f))
-         ;; Pull state for specificied host.
-         ;; It is not a good idea to pull for all configured hosts
-         ;; when no host is specified on the command line. Since
+         ;; Pull state for specificied project.
+         ;; It is not a good idea to pull for all configured projects
+         ;; when no project is specified on the command line. Since
          ;; pulling requires executing code in each repository,
-         ;; pulling for multiple hosts in a single process can cause
-         ;; interaction of code across hosts.
-         (let ((hostname (assq-ref args 'host)))
+         ;; pulling for multiple projects in a single process can
+         ;; cause interaction of code across projects.
+         (let ((project-name (assq-ref args 'project)))
            (cond
-            ((assoc-ref (assq-ref args 'hosts)
-                        hostname)
+            ((assoc-ref (append-map (match-lambda
+                                      ((_ . parameters)
+                                       (assq-ref parameters 'projects)))
+                                    (assq-ref args 'hosts))
+                        project-name)
              => (lambda (parameters)
                   (pull state-directory
-                        hostname
+                        project-name
                         (assq-ref parameters 'upstream-repository))))
             (else
              (format (current-error-port)
-                     "Host ~a not found in configuration file."
-                     hostname)
+                     "Project ~a not found in configuration file."
+                     project-name)
              (exit #f)))))))))
 
 (define (main args)
diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index e8ee9eb..afb259f 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.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.
 ;;;
@@ -143,6 +143,36 @@ query. QUERY and FILTER are Xapian Query objects."
       (list path
             (string-append path ".html"))))
 
+(define (relative-file-name* file-name base)
+  "Work around @code{relative-file-name} from @code{(ice-9 filesystem)}
+for bug @url{https://gitlab.com/lilyp/guile-filesystem/issues/1}
+regarding handling root @var{base}"
+  (if (string=? base "/")
+      (relative-file-name (string-append "/foo" file-name)
+                          "/foo")
+      (relative-file-name file-name base)))
+
+(define (rebase-uri-path path base)
+  "Rebase URI @var{path} on top of @var{base}, both absolute paths that
+start with a slash.
+
+Care is taken to preserve trailing slashes in @var{path} and ignore
+trailing slashes in @var{base}.
+
+For example,
+(rebase-uri-path \"/tissue/foo\" \"/tissue\") => \"/foo\"
+(rebase-uri-path \"/tissue/foo/\" \"/tissue\") => \"/foo/\"
+(rebase-uri-path \"/tissue/\" \"/tissue\") => \"/\"
+"
+  (let* ((relative-path (relative-file-name* path base))
+         (rebased-path (if (string=? relative-path ".")
+                           "/"
+                           (string-append "/" relative-path))))
+    (if (and (string-suffix? "/" path)
+             (not (string-suffix? "/" rebased-path)))
+        (string-append rebased-path "/")
+        rebased-path)))
+
 (define (handler request body hosts)
   "Handle web REQUEST with BODY and return two values---the response
 headers and the body.
@@ -155,7 +185,15 @@ See `start-web-server' for documentation of HOSTS."
                               (raise (condition
                                       (make-message-condition "Unknown host")
                                       (make-irritants-condition hostname)))))
-         (repository-directory (assq-ref host-parameters 'repository-directory)))
+         (project-parameters (any (match-lambda
+                                    ((_ . project-parameters)
+                                     (and (string-prefix? (assq-ref project-parameters 'base-path)
+                                                          (uri-path (request-uri request)))
+                                          project-parameters)))
+                                  (assq-ref host-parameters 'projects)))
+         (path (rebase-uri-path path (assq-ref project-parameters 'base-path)))
+         (repository-directory (assq-ref project-parameters
+                                         'repository-directory)))
     (log-request request)
     (parameterize ((%current-git-repository
                     (repository-open repository-directory)))
@@ -163,12 +201,14 @@ See `start-web-server' for documentation of HOSTS."
        ;; Static files
        ((let ((file-path
                (find file-exists?
-                     (map (cut string-append (assq-ref host-parameters 'website-directory) <>)
+                     (map (cut string-append
+                               (assq-ref project-parameters 'website-directory)
+                               <>)
                           (try-paths path)))))
           (and file-path
                ;; Check that the file really is within the document
                ;; root.
-               (string-prefix? (string-append (assq-ref host-parameters 'website-directory) "/")
+               (string-prefix? (string-append (assq-ref project-parameters 'website-directory) "/")
                                (canonicalize-path file-path))
                (canonicalize-path file-path)))
         => (lambda (file-path)
@@ -181,8 +221,8 @@ See `start-web-server' for documentation of HOSTS."
        ;; necessary.
        ((member path (list "/" "/search"))
         (search-handler request body
-                        (assq-ref host-parameters 'xapian-directory)
-                        (assq-ref host-parameters 'project)))
+                        (assq-ref project-parameters 'xapian-directory)
+                        (assq-ref project-parameters 'project)))
        ;; Not found
        (else
         (404-response request))))))