diff options
Diffstat (limited to 'tissue/web/server.scm')
| -rw-r--r-- | tissue/web/server.scm | 391 |
1 files changed, 127 insertions, 264 deletions
diff --git a/tissue/web/server.scm b/tissue/web/server.scm index fa26aa5..e8ee9eb 100644 --- a/tissue/web/server.scm +++ b/tissue/web/server.scm @@ -1,5 +1,5 @@ ;;; tissue --- Text based issue tracker -;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of tissue. ;;; @@ -25,6 +25,7 @@ #: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)) @@ -38,182 +39,24 @@ (case symbol ((parse-query) 'xapian:parse-query) (else symbol)))) - #:use-module (tissue document) #:use-module (tissue git) #:use-module (tissue search) + #:use-module (tissue tissue) #:use-module (tissue utils) - #:export (start-web-server)) - -(define %css - " -body { - max-width: 1000px; - margin: 0 auto; -} - -form { text-align: center; } -.search-filter { - background-color: gray; - color: white; - padding: 0 0.2em; -} - -.search-results-statistics { - list-style: none; - padding: 0; -} -.search-results-statistics li { - display: inline; - margin: 0.5em; -} -.search-results-statistics a { color: blue; } -.current-search-type { font-weight: bold; } - -.search-results { padding: 0; } -.search-result { - list-style-type: none; - padding: 0.5em; -} -.search-result a { text-decoration: none; } -.document-type { - font-variant: small-caps; - font-weight: bold; -} -.search-result-metadata { - color: dimgray; - font-size: smaller; -} -.search-result-snippet { font-size: smaller; } - -.tags { - list-style-type: none; - padding: 0; - display: inline; -} -.tag { display: inline; } -.tag a { - padding: 0 0.2em; - color: white; - background-color: blue; - margin: auto 0.25em; - font-size: smaller; -} -.tag-bug a { background-color: red; } -.tag-feature a { background-color: green; } -.tag-progress a, .tag-unassigned a { - background-color: orange; - color: black; -} -.tag-chore a { - background-color: khaki; - color: black; -}") - -(define* (make-search-page results query css - #:key - page-uri-path page-uri-parameters - matches - matched-open-issues matched-closed-issues - matched-documents matched-commits - current-search-type) - "Return SXML for a page with search RESULTS produced for QUERY. - -CSS is a URI to a stylesheet. PAGE-URI-PATH is the path part of the -URI to the page. PAGE-URI-PARAMETERS is an association list of -parameters in the query string of the URI of the page. - -MATCHES is the number of matches. MATCHED-OPEN-ISSUES, -MATCHED-CLOSED-ISSUES, MATCHED-DOCUMENTS and MATCHED-COMMITS are -respectively the number of open issues, closed issues, documents and -commits matching the current query. CURRENT-SEARCH-TYPE is the type of -document search results are being showed for." - `(html - (head - (title "Tissue search") - (style ,%css) - ,@(if css - (list `(link (@ (href "/style.css") - (rel "stylesheet") - (type "text/css")))) - (list))) - (body - (form (@ (action "/search") (method "GET")) - (input (@ (type "text") - (name "query") - (value ,query) - (placeholder "Enter search query"))) - (input (@ (type "hidden") - (name "type") - (value ,(symbol->string current-search-type)))) - (input (@ (type "submit") (value "Search")))) - (details (@ (class "search-hint")) - (summary "Hint") - (p "Refine your search with filters " - ,@(append-map (lambda (filter) - (list `(span (@ (class "search-filter")) - ,filter) - ", ")) - (list "type:issue" - "type:document" - "is:open" - "is:closed" - "title:git" - "creator:mani" - "lastupdater:vel" - "assigned:muthu" - "tag:feature-request")) - "etc. Optionally, combine search terms with boolean -operators " - (span (@ (class "search-filter")) - "AND") - " and " - (span (@ (class "search-filter")) - "OR") - ". See " (a (@ (href "https://xapian.org/docs/queryparser.html")) - "Xapian::QueryParser Syntax") - " for detailed documentation.")) - ,(let ((search-result-statistic - (lambda (search-type format-string matches) - `(li (a (@ (href ,(string-append - page-uri-path - "?" - (query-string - (acons "type" (symbol->string search-type) - (alist-delete "type" page-uri-parameters))))) - ,@(if (eq? search-type current-search-type) - '((class "current-search-type")) - '())) - ,(format #f format-string matches)))))) - `(ul (@ (class "search-results-statistics")) - ,(search-result-statistic 'all "~a All" matches) - ,(search-result-statistic 'open-issue "~a open issues" matched-open-issues) - ,(search-result-statistic 'closed-issue "~a closed issues" matched-closed-issues) - ,(search-result-statistic 'document "~a documents" matched-documents) - ,(search-result-statistic 'commit "~a commits" matched-commits))) - (ul (@ (class "search-results")) - ,@results)))) - -(define (query-parameters query) - "Return an association list of query parameters in web QUERY string." - (if query - (map (lambda (parameter) - (match (string-split parameter #\=) - ((key value) - (cons (uri-decode key) - (uri-decode value))))) - (string-split query #\&)) - '())) - -(define (query-string parameters) - "Return a query string for association list of PARAMETERS." - (string-join - (map (match-lambda - ((key . value) - (string-append (uri-encode key) - "=" - (uri-encode value)))) - parameters) - "&")) + #: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) @@ -227,6 +70,20 @@ operators " ("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." @@ -236,85 +93,78 @@ query. QUERY and FILTER are Xapian Query objects." 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 <search-page> + #: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))) - (parameters (query-parameters (uri-query (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)))))) - (format #t "~a ~a\n" - (request-method request) - path) + (make-irritants-condition hostname))))) + (repository-directory (assq-ref host-parameters 'repository-directory))) + (log-request request) (parameterize ((%current-git-repository - (repository-open - (assq-ref host-parameters 'repository-directory)))) + (repository-open repository-directory))) (cond - ;; Search page - ((member path (list "/" "/search")) - (let* ((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 (assq-ref host-parameters 'xapian-directory) - (lambda (db) - (let* ((query (parse-query search-query)) - (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 (database-document-count db)))) - (make-search-page - (reverse - (mset-fold (lambda (item result) - (cons (document->sxml - (call-with-input-string (document-data (mset-item-document item)) - (compose scm->object read)) - mset) - result)) - '() - mset)) - search-query - (assq-ref host-parameters 'css) - #:page-uri-path path - #:page-uri-parameters parameters - #: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)) - #:current-search-type search-type)))))))) ;; Static files ((let ((file-path (find file-exists? - ;; Try path and path.html. - (list (string-append (assq-ref host-parameters 'website-directory) - "/" path) - (string-append (assq-ref host-parameters 'website-directory) - "/" path ".html"))))) + (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. @@ -322,16 +172,20 @@ See `start-web-server' for documentation of HOSTS." (canonicalize-path file-path)) (canonicalize-path file-path))) => (lambda (file-path) - (values `((content-type . ,(or (assoc-ref %mime-types (string-remove-prefix - "." (file-name-extension file-path))) - '(application/octet-stream)))) + (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 - (values (build-response #:code 404) - (string-append "Resource not found: " - (uri->string (request-uri request))))))))) + (404-response request)))))) (define (start-web-server socket-address hosts) "Start web server listening on SOCKET-ADDRESS. @@ -356,24 +210,33 @@ list containing parameters for that host." ;; Unix socket ((= (sockaddr:fam socket-address) AF_UNIX) (sockaddr:path socket-address)))) - (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) - (let ((socket (make-unix-domain-server-socket - #:path (sockaddr:path socket-address)))) - ;; Grant read-write permissions to all users. - (chmod (sockaddr:path socket-address) #o666) - (list #:socket socket)))))) + (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))))))) |