diff options
| -rwxr-xr-x | bin/tissue | 10 | ||||
| -rw-r--r-- | tissue/web/dev.scm | 75 | ||||
| -rw-r--r-- | tissue/web/server.scm | 1 |
3 files changed, 51 insertions, 35 deletions
@@ -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) |