diff options
| -rwxr-xr-x | bin/tissue | 63 | ||||
| -rw-r--r-- | tissue/web/server.scm | 52 |
2 files changed, 87 insertions, 28 deletions
@@ -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)))))) |