path: root/tissue/web/server.scm

;;; tissue --- Text based issue tracker
;;; Copyright © 2022 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 (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 document)
  #:use-module (tissue git)
  #:use-module (tissue search)
  #:use-module (tissue utils)
  #:export (start-web-server))

(define %css
  "
body {
    max-width: 1000px;
    margin: 0 auto;
}

form { text-align: center; }
.search-hint { line-height: 2em; }
.search-filter {
    background-color: gray;
    color: white;
    border-radius: 0.2em;
    padding: 0 0.2em;
}

.search-results-statistics {
    list-style: none;
    padding: 0;
}
.search-results-statistics li {
    display: inline;
    margin: 0.5em;
}
.search-results-statistics a { color: blue; }
.current-search-type { font-weight: bold; }

.search-results { padding: 0; }
.search-result {
    list-style-type: none;
    padding: 0.5em;
}
.search-result a {
    text-decoration: none;
    font-size: larger;
}
.search-result-title, .search-result-title:before { vertical-align: middle; }
.search-result-commit .search-result-metadata:before,
.search-result-document .search-result-title:before,
.search-result-issue .search-result-metadata:before {
    font-size: xx-small;
    font-weight: bold;
    margin: 0 0.2em;
    padding: 0 0.4em;
    background-color: darkmagenta;
    color: white;
}
.search-result-commit .search-result-metadata:before { content: \"COMMIT\"; }
.search-result-document .search-result-title:before { content: \"DOC\"; }
.search-result-open-issue .search-result-metadata:before {
    content: \"ISSUE\";
    background-color: green;
}
.search-result-closed-issue .search-result-metadata:before { content: \"✓ ISSUE\"; }
.search-result-metadata {
    color: dimgray;
    font-size: smaller;
}
.search-result-snippet { font-size: smaller; }

a.tag {
    padding: 0.25em 0.4em;
    color: white;
    background-color: blue;
    border-radius: 0.5em;
    margin: auto 0.25em;
    font-size: smaller;
}
a.tag-bug { background-color: red; }
a.tag-feature { background-color: green; }
a.tag-progress, a.tag-unassigned {
    background-color: orange;
    color: black;
}
a.tag-chore {
    background-color: khaki;
    color: black;
}")

(define* (make-search-page results query css
                           #:key
                           page-uri-path page-uri-parameters
                           matches
                           matched-open-issues matched-closed-issues
                           matched-documents matched-commits
                           current-search-type)
  "Return SXML for a page with search RESULTS produced for QUERY.

CSS is a URI to a stylesheet. PAGE-URI-PATH is the path part of the
URI to the page. PAGE-URI-PARAMETERS is an association list of
parameters in the query string of the URI of the page.

MATCHES is the number of matches. MATCHED-OPEN-ISSUES,
MATCHED-CLOSED-ISSUES, MATCHED-DOCUMENTS and MATCHED-COMMITS are
respectively the number of open issues, closed issues, documents and
commits matching the current query. CURRENT-SEARCH-TYPE is the type of
document search results are being showed for."
  `(html
    (head
     (title "Tissue search")
     (style ,%css)
     ,@(if css
           (list `(link (@ (href "/style.css")
                           (rel "stylesheet")
                           (type "text/css"))))
           (list)))
    (body
     (form (@ (action "/search") (method "GET"))
           (input (@ (type "text")
                     (name "query")
                     (value ,query)
                     (placeholder "Enter search query")))
           (input (@ (type "hidden")
                     (name "type")
                     (value ,(symbol->string current-search-type))))
           (input (@ (type "submit") (value "Search"))))
     (details (@ (class "search-hint"))
              (summary "Hint")
              (p "Refine your search with filters "
                 ,@(append-map (lambda (filter)
                                 (list `(span (@ (class "search-filter"))
                                              ,filter)
                                       ", "))
                               (list "type:issue"
                                     "type:document"
                                     "is:open"
                                     "is:closed"
                                     "title:git"
                                     "creator:mani"
                                     "lastupdater:vel"
                                     "assigned:muthu"
                                     "tag:feature-request"))
                 "etc. Optionally, combine search terms with boolean
operators "
                 (span (@ (class "search-filter"))
                       "AND")
                 " and "
                 (span (@ (class "search-filter"))
                       "OR")
                 "."))
     ,(let ((search-result-statistic
             (lambda (search-type format-string matches)
               `(li (a (@ (href ,(string-append
                                  page-uri-path
                                  "?"
                                  (query-string
                                   (acons "type" (symbol->string search-type)
                                          (alist-delete "type" page-uri-parameters)))))
                          ,@(if (eq? search-type current-search-type)
                                '((class "current-search-type"))
                                '()))
                       ,(format #f format-string matches))))))
        `(ul (@ (class "search-results-statistics"))
             ,(search-result-statistic 'all "~a All" matches)
             ,(search-result-statistic 'open-issue "~a open issues" matched-open-issues)
             ,(search-result-statistic 'closed-issue "~a closed issues" matched-closed-issues)
             ,(search-result-statistic 'document "~a documents" matched-documents)
             ,(search-result-statistic 'commit "~a commits" matched-commits)))
     (ul (@ (class "search-results"))
         ,@results))))

(define (query-parameters query)
  "Return an association list of query parameters in web QUERY string."
  (if query
      (map (lambda (parameter)
             (match (string-split parameter #\=)
               ((key value)
                (cons (uri-decode key)
                      (uri-decode value)))))
           (string-split query #\&))
      '()))

(define (query-string parameters)
  "Return a query string for association list of PARAMETERS."
  (string-join
   (map (match-lambda
          ((key . value)
           (string-append (uri-encode key)
                          "="
                          (uri-encode value))))
        parameters)
   "&"))

(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 (matches db search-query filter)
  "Return the number of matches in DB for SEARCH-QUERY filtering with
FILTER query."
  (MSet-get-matches-estimated
   (enquire-mset
    (enquire
     db (new-Query (Query-OP-FILTER)
                   (parse-query search-query)
                   filter))
    #:maximum-items (database-document-count db))))

(define (handler request body hosts state-directory)
  "Handle web REQUEST with BODY and return two values---the response
headers and body.

See `start-web-server' for documentation of HOSTS and
STATE-DIRECTORY."
  (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)
    (parameterize ((%current-git-repository
                    (repository-open
                     (string-append state-directory "/" hostname "/repository"))))
      (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 (string-append state-directory "/" hostname "/xapian")
                     (lambda (db)
                       (let ((mset (enquire-mset (enquire db (new-Query (Query-OP-FILTER)
                                                                        (parse-query search-query)
                                                                        (or (assq-ref filter-alist search-type)
                                                                            (Query-MatchAll))))
                                                 #: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 search-query (Query-MatchAll))
                          #:matched-open-issues (matches db search-query (assq-ref filter-alist 'open-issue))
                          #:matched-closed-issues (matches db search-query (assq-ref filter-alist 'closed-issue))
                          #:matched-documents (matches db search-query (assq-ref filter-alist 'document))
                          #:matched-commits (matches db search-query (assq-ref filter-alist 'commit))
                          #:current-search-type search-type))))))))
       ;; Static files
       ((let ((file-path
               (find file-exists?
                     ;; Try path and path.html.
                     (list (string-append state-directory "/" hostname "/website" path)
                           (string-append state-directory "/" hostname "/website" path ".html")))))
          (and file-path
               ;; Check that the file really is within the document
               ;; root.
               (string-prefix? (string-append state-directory "/" hostname "/website/")
                               (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))))
                     ;; Return a procedure so that the file can be
                     ;; read out a little at a time instead of having
                     ;; to load it whole into memory.
                     (lambda (out)
                       (call-with-input-file file-path
                         (lambda (in)
                           (port-transduce (tmap (cut put-bytevector out <>))
                                           (const #t)
                                           get-bytevector-some
                                           in)))))))
       ;; Not found
       (else
        (values (build-response #:code 404)
                (string-append "Resource not found: "
                               (uri->string (request-uri request)))))))))

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

HOSTS is an association list mapping host names to another association
list containing parameters for that host. STATE-DIRECTORY is the path
to the tissue state directory."
  (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))))
  (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 state-directory))
              '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)
                (let ((socket (make-unix-domain-server-socket
                               #:path (sockaddr:path socket-address))))
                  ;; Grant read-write permissions to all users.
                  (chmod (sockaddr:path socket-address) #o666)
                  (list #:socket socket))))))