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.

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.