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.

1 files changed, 41 insertions, 22 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)