From c6f9002a10d0693c801c38aad748d19befeecf4f Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Sat, 24 Dec 2022 00:32:52 +0000
Subject: server: Factor out reusable parts into separate functions.
The newly factored out functions will be used in the upcoming
development web server.
* tissue/web/server.scm (handler): Factor out reusable parts into ...
(log-request, mime-type-for-extension, 404-response, search-handler,
try-paths): ... new functions.
---
tissue/web/server.scm | 164 +++++++++++++++++++++++++++++---------------------
1 file changed, 95 insertions(+), 69 deletions(-)
diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index 909a4f5..f5e601b 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.scm
@@ -42,7 +42,12 @@
#:use-module (tissue git)
#:use-module (tissue search)
#:use-module (tissue utils)
- #:export (start-web-server))
+ #:export (log-request
+ mime-type-for-extension
+ try-paths
+ 404-response
+ search-handler
+ start-web-server))
(define %css
"
@@ -215,6 +220,12 @@ operators "
parameters)
"&"))
+(define (log-request request)
+ "Log @var{request} to standard output."
+ (format #t "~a ~a\n"
+ (request-method request)
+ (uri-path (request-uri request))))
+
(define %mime-types
'(("gif" image/gif)
("html" text/html)
@@ -227,6 +238,18 @@ 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 (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,89 +259,95 @@ 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 css)
+ (let* ((path (uri-path (request-uri request)))
+ (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)
+ (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
+ 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))))))))
+
+(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)
+ (log-request request)
(parameterize ((%current-git-repository
(repository-open
(assq-ref host-parameters '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))))))))
+ (search-handler request body
+ (assq-ref host-parameters 'xapian-directory)
+ (assq-ref host-parameters 'css)))
;; Static files
((let ((file-path
(find file-exists?
- (if (string-suffix? "/" path)
- ;; Try path/index.html.
- (list (string-append (assq-ref host-parameters 'website-directory)
- path "index.html"))
- ;; 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.
@@ -326,16 +355,13 @@ 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))))
;; 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.
--
cgit v1.2.3