diff options
| -rwxr-xr-x | bin/tissue | 4 | ||||
| -rw-r--r-- | tissue/web/server.scm | 91 |
2 files changed, 57 insertions, 38 deletions
diff --git a/bin/tissue b/bin/tissue index bf69100..4b524b8 100755 --- a/bin/tissue +++ b/bin/tissue @@ -251,6 +251,10 @@ Run a web search service reading configuration from CONFIG-FILE. listen-repl) (make-unix-domain-server-socket #:path listen-repl)))))) (start-web-server (listen->socket-address (assq-ref args 'listen)) + (or (assq-ref args 'hosts) + ;; Assume current directory as default. + `(("localhost" + (indexed-repository . ,(getcwd))))) %xapian-index (tissue-configuration-web-css (load-config))))))) diff --git a/tissue/web/server.scm b/tissue/web/server.scm index dec0a35..89e8104 100644 --- a/tissue/web/server.scm +++ b/tissue/web/server.scm @@ -36,6 +36,7 @@ #:use-module (tissue conditions) #:use-module (tissue document) #:use-module (tissue search) + #:use-module (tissue utils) #:export (start-web-server)) (define %css @@ -164,49 +165,63 @@ operators " (string-split query #\&)) '())) -(define (handler request body xapian-index css) +(define (handler request body hosts xapian-index css) "Handle web REQUEST with BODY and return two values---the response -headers and body. XAPIAN-INDEX is the path to the xapian database -relative to the top-level of the current git repository. CSS is a URI -to a stylesheet." +headers and body. + +See `start-web-server' for documentation of HOSTS, XAPIAN-INDEX and +CSS." (let ((path (uri-path (request-uri request))) - (parameters (query-parameters (uri-query (request-uri request))))) + (parameters (query-parameters (uri-query (request-uri request)))) + (host-parameters (or (assoc-ref hosts + (match (assq-ref (request-headers request) 'host) + ((hostname . _) hostname))) + ;; If no matching host is found, pick the + ;; first known host. + (match hosts + (((_ . host-parameters) _ ...) + host-parameters))))) (format #t "~a ~a\n" (request-method request) path) - (cond - ((member path (list "/" "/search")) - (let ((search-query (or (assoc-ref parameters "query") - ""))) - (values '((content-type . (text/html))) - (sxml->html - (call-with-database xapian-index - (lambda (db) - (let ((mset (enquire-mset (enquire db (parse-query search-query)) - #: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 - (MSet-get-matches-estimated mset) - css)))))))) - (else - (values (build-response #:code 404) - (string-append "Resource not found: " - (uri->string (request-uri request)))))))) + (call-with-current-directory (assq-ref host-parameters 'indexed-repository) + (lambda () + (cond + ((member path (list "/" "/search")) + (let ((search-query (or (assoc-ref parameters "query") + ""))) + (values '((content-type . (text/html))) + (sxml->html + (call-with-database xapian-index + (lambda (db) + (let ((mset (enquire-mset (enquire db (parse-query search-query)) + #: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 + (MSet-get-matches-estimated mset) + css)))))))) + (else + (values (build-response #:code 404) + (string-append "Resource not found: " + (uri->string (request-uri request)))))))))) + +(define (start-web-server socket-address hosts xapian-index css) + "Start web server listening on SOCKET-ADDRESS. -(define (start-web-server socket-address xapian-index css) - "Start web server listening on SOCKET-ADDRESS. XAPIAN-INDEX is the -path to the xapian database relative to the top-level of the current -git repository. CSS is a URI to a stylesheet." +HOSTS is an association list mapping host names to another association +list containing parameters for that host. XAPIAN-INDEX is the path to +the xapian database relative to the top-level of the git +repository. CSS is a URI to a stylesheet." (format (current-error-port) "Tissue web server listening on ~a~%" (cond @@ -230,7 +245,7 @@ git repository. CSS is a URI to a stylesheet." ;; variable each time so as to support live hacking. ((module-ref (resolve-module '(tissue web server)) 'handler) - request body xapian-index css)) + request body hosts xapian-index css)) 'http (cond ;; IPv4 or IPv6 address |