diff options
| -rw-r--r-- | tissue/web/server.scm | 164 |
1 files 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. |