path: root/tissue/web/server.scm

;;; tissue --- Text based issue tracker
;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of tissue.
;;;
;;; tissue is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; tissue is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with tissue.  If not, see <https://www.gnu.org/licenses/>.

(define-module (tissue web server)
  #:use-module (rnrs conditions)
  #:use-module (rnrs exceptions)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #: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))
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web server)
  #:use-module (web uri)
  #:use-module (git)
  #:use-module (xapian wrap)
  #:use-module ((xapian xapian) #:renamer (lambda (symbol)
                                            (case symbol
                                              ((parse-query) 'xapian:parse-query)
                                              (else symbol))))
  #:use-module (tissue git)
  #:use-module (tissue search)
  #:use-module (tissue tissue)
  #:use-module (tissue utils)
  #: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)
    ("html" text/html)
    ("jpeg" image/jpeg)
    ("jpg" image/jpeg)
    ("js" text/javascript)
    ("json" application/json)
    ("png" image/png)
    ("pdf" application/pdf)
    ("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."
  (MSet-get-matches-estimated
   (enquire-mset
    (enquire
     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)))
         (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)))))
         (repository-directory (assq-ref host-parameters 'repository-directory)))
    (log-request request)
    (parameterize ((%current-git-repository
                    (repository-open repository-directory)))
      (cond
       ;; Static files
       ((let ((file-path
               (find file-exists?
                     (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.
               (string-prefix? (string-append (assq-ref host-parameters 'website-directory) "/")
                               (canonicalize-path file-path))
               (canonicalize-path file-path)))
        => (lambda (file-path)
             (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
        (404-response request))))))

(define (start-web-server socket-address hosts)
  "Start web server listening on SOCKET-ADDRESS.

HOSTS is an association list mapping host names to another association
list containing parameters for that host."
  (format (current-error-port)
          "Tissue web server listening on ~a~%"
          (cond
           ;; IPv4 address
           ((= (sockaddr:fam socket-address) AF_INET)
            (format #f "~a:~a"
                    (inet-ntop (sockaddr:fam socket-address)
                               (sockaddr:addr socket-address))
                    (sockaddr:port socket-address)))
           ;; IPv6 address
           ((= (sockaddr:fam socket-address) AF_INET6)
            (format #f "[~a]:~a"
                    (inet-ntop (sockaddr:fam socket-address)
                               (sockaddr:addr socket-address))
                    (sockaddr:port socket-address)))
           ;; Unix socket
           ((= (sockaddr:fam socket-address) AF_UNIX)
            (sockaddr:path socket-address))))
  (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)))))))