;;; tissue --- Text based issue tracker ;;; Copyright © 2022, 2023 Arun Isaac ;;; ;;; This file is part of tissue. ;;; ;;; tissue is free software: you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; tissue is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with tissue. If not, see . (define-module (tissue web server) #:use-module (rnrs conditions) #:use-module (rnrs exceptions) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-171) #:use-module (ice-9 filesystem) #:use-module (ice-9 match) #:use-module (oop goops) #:use-module (htmlprag) #:use-module (sxml simple) #:use-module ((system repl server) #:select (make-unix-domain-server-socket)) #:use-module (web request) #:use-module (web response) #:use-module (web server) #:use-module (web uri) #:use-module (git) #:use-module (xapian wrap) #:use-module ((xapian xapian) #:renamer (lambda (symbol) (case symbol ((parse-query) 'xapian:parse-query) (else symbol)))) #:use-module (tissue git) #:use-module (tissue search) #:use-module (tissue tissue) #:use-module (tissue utils) #:use-module (tissue web themes) #:export (log-request mime-type-for-extension try-paths 404-response search-handler start-web-server)) (define (log-request request) "Log @var{request} to standard output." (display (request-method request)) (display " ") (display (uri->string (request-uri request))) (newline)) (define %mime-types '(("gif" image/gif) ("html" text/html) ("jpeg" image/jpeg) ("jpg" image/jpeg) ("js" text/javascript) ("json" application/json) ("png" image/png) ("pdf" application/pdf) ("svg" image/svg+xml) ("txt" text/plain))) (define (mime-type-for-extension extension) "Return the mime type for @var{extension}." (or (assoc-ref %mime-types (if (string-null? extension) extension (string-remove-prefix "." extension))) '(application/octet-stream))) (define (404-response request) "Return a response and body for a 404 error corresponding to @var{request}." (values (build-response #:code 404) (string-append "Resource not found: " (uri->string (request-uri request))))) (define (matches db query filter) "Return the number of matches in DB for QUERY filtering with FILTER query. QUERY and FILTER are Xapian Query objects." (MSet-get-matches-estimated (enquire-mset (enquire db (new-Query (Query-OP-FILTER) query filter)) #:maximum-items (database-document-count db)))) (define (search-handler request body xapian-index project) (let* ((parameters (query-parameters (uri-query (request-uri request)))) (search-query (or (assoc-ref parameters "query") "")) (search-type (match (assoc-ref parameters "type") ((or "open-issue" "closed-issue" "commit" "document") (string->symbol (assoc-ref parameters "type"))) (_ 'all))) (filter-alist `((open-issue . ,(parse-query "type:issue AND is:open")) (closed-issue . ,(parse-query "type:issue AND is:closed")) (commit . ,(parse-query "type:commit")) (document . ,(parse-query "type:document"))))) (values '((content-type . (text/html))) (sxml->html (call-with-database xapian-index (lambda (db) ((tissue-configuration-web-search-renderer project) (let ((query (parse-query search-query))) (make #:uri (request-uri request) #:query search-query #:type search-type #:mset (enquire-mset (let* ((query (new-Query (Query-OP-FILTER) query (or (assq-ref filter-alist search-type) (Query-MatchAll)))) (enquire (enquire db query))) ;; Sort by recency date (slot 0) when ;; query is strictly boolean. (when (boolean-query? query) (Enquire-set-sort-by-value enquire 0 #t)) enquire) #:offset 0 #:maximum-items 1000) #:matches (matches db query (Query-MatchAll)) #:matched-open-issues (matches db query (assq-ref filter-alist 'open-issue)) #:matched-closed-issues (matches db query (assq-ref filter-alist 'closed-issue)) #:matched-documents (matches db query (assq-ref filter-alist 'document)) #:matched-commits (matches db query (assq-ref filter-alist 'commit))))))))))) (define (try-paths path) "Return a list of candidate paths to look for @var{path}." (if (string-suffix? "/" path) ;; Try path/index.html. (list (string-append path "index.html")) ;; Try path and path.html. (list path (string-append path ".html")))) (define (handler request body hosts) "Handle web REQUEST with BODY and return two values---the response headers and the body. See `start-web-server' for documentation of HOSTS." (let* ((path (uri-path (request-uri request))) (hostname (match (assq-ref (request-headers request) 'host) ((hostname . _) hostname))) (host-parameters (or (assoc-ref hosts hostname) (raise (condition (make-message-condition "Unknown host") (make-irritants-condition hostname))))) (repository-directory (assq-ref host-parameters 'repository-directory))) (log-request request) (parameterize ((%current-git-repository (repository-open repository-directory))) (cond ;; Static files ((let ((file-path (find file-exists? (map (cut string-append (assq-ref host-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) "/") (canonicalize-path file-path)) (canonicalize-path file-path))) => (lambda (file-path) (values `((content-type . ,(mime-type-for-extension (file-name-extension file-path)))) (call-with-input-file file-path get-bytevector-all)))) ;; 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 (assq-ref host-parameters 'xapian-directory) (assq-ref host-parameters 'project))) ;; Not found (else (404-response request)))))) (define (start-web-server socket-address hosts) "Start web server listening on SOCKET-ADDRESS. HOSTS is an association list mapping host names to another association list containing parameters for that host." (format (current-error-port) "Tissue web server listening on ~a~%" (cond ;; IPv4 address ((= (sockaddr:fam socket-address) AF_INET) (format #f "~a:~a" (inet-ntop (sockaddr:fam socket-address) (sockaddr:addr socket-address)) (sockaddr:port socket-address))) ;; IPv6 address ((= (sockaddr:fam socket-address) AF_INET6) (format #f "[~a]:~a" (inet-ntop (sockaddr:fam socket-address) (sockaddr:addr socket-address)) (sockaddr:port socket-address))) ;; Unix socket ((= (sockaddr:fam socket-address) AF_UNIX) (sockaddr:path socket-address)))) (let ((unix-socket #f)) (dynamic-wind (lambda () (when (= (sockaddr:fam socket-address) AF_UNIX) (set! socket (make-unix-domain-server-socket #:path (sockaddr:path socket-address))) ;; Grant read-write permissions to all users. (chmod (sockaddr:path socket-address) #o666))) (cut run-server (lambda (request body) ;; Explicitly dereference the module and handler ;; variable each time so as to support live hacking. ((module-ref (resolve-module '(tissue web server)) 'handler) request body hosts)) 'http (cond ;; IPv4 or IPv6 address ((or (= (sockaddr:fam socket-address) AF_INET) (= (sockaddr:fam socket-address) AF_INET6)) (list #:family (sockaddr:fam socket-address) #:addr (sockaddr:addr socket-address) #:port (sockaddr:port socket-address))) ;; Unix socket ((= (sockaddr:fam socket-address) AF_UNIX) (list #:socket socket)))) (lambda () ;; Clean up socket file if Unix socket. (when (= (sockaddr:fam socket-address) AF_UNIX) (delete-file (sockaddr:path socket-address)))))))