web: server: Add web server for search.

* tissue/web/server.scm: New file.
* tissue/document.scm (document-sxml-snippet): New public function.
(document->sxml): New generic method.
* tissue/issue.scm: Import (web uri).
(document->sxml): New generic method.
* bin/tissue: Import (system repl server) and (tissue web server).
(address->socket-address, tissue-run-web): New function.
(print-usage): List `tissue run-web' subcommand.
(main): Call tissue-run-web.

4 files changed, 357 insertions, 0 deletions

diff --git a/bin/tissue b/bin/tissue
index e29cf3c..d7d4424 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -32,6 +32,7 @@ exec guile --no-auto-compile -s "$0" "$@"
         (ice-9 match)
         (ice-9 popen)
         (ice-9 regex)
+        (system repl server)
         (term ansi-color)
         (git)
         (xapian wrap)
@@ -43,6 +44,7 @@ exec guile --no-auto-compile -s "$0" "$@"
         (tissue search)
         (tissue tissue)
         (tissue utils)
+        (tissue web server)
         (tissue web static))
 
 (define %state-directory
@@ -190,6 +192,72 @@ Export the repository as a website to OUTPUT-DIRECTORY.
                       (tissue-configuration-web-css (load-config))
                       (tissue-configuration-web-files (load-config)))))))
 
+(define (address->socket-address address port)
+  "Convert ADDRESS and PORT to a socket address."
+  (cond
+   ;; IPv4
+   ((string-contains address ".")
+    (make-socket-address AF_INET
+                         (inet-pton AF_INET address)
+                         port))
+   ;; IPv6
+   ((string-contains address ":")
+    (make-socket-address AF_INET6
+                         (inet-pton AF_INET6 address)
+                         port))
+   ;; Unix socket
+   (else
+    (make-socket-address AF_UNIX address))))
+
+(define tissue-run-web
+  (match-lambda*
+    (("--help")
+     (format #t "Usage: ~a run-web
+Run a web search service for the current repository.
+
+  --address=IP       run web server listening on IP address [default=127.0.0.1]
+  --port=PORT        run web server listening on PORT [default=8080]
+  --listen-repl=P    run REPL server listening on port or path P
+"
+             (command-line-program)))
+    (args
+     (let ((args (args-fold args
+                            (list (option (list "address")
+                                          #t #f
+                                          (lambda (opt name arg result)
+                                            (acons 'address arg result)))
+                                  (option (list "port")
+                                          #t #f
+                                          (lambda (opt name arg result)
+                                            (acons 'port (string->number arg)
+                                                   result)))
+                                  (option '("listen-repl")
+                                          #t #f
+                                          (lambda (opt name arg result)
+                                            (acons 'listen-repl arg result))))
+                            invalid-option
+                            invalid-operand
+                            ;; Default address and port
+                            '((address . "127.0.0.1")
+                              (port . 8080)))))
+       (let ((listen-repl (assq-ref args 'listen-repl)))
+         (when listen-repl
+           (spawn-server (cond
+                          ((string? listen-repl)
+                           (format (current-error-port)
+                                   "REPL server listening on port ~a~%"
+                                   listen-repl)
+                           (make-unix-domain-server-socket #:path listen-repl))
+                          (else
+                           (format (current-error-port)
+                                   "REPL server listening on ~a~%"
+                                   listen-repl)
+                           (make-unix-domain-server-socket #:path listen-repl))))))
+       (start-web-server (address->socket-address (assq-ref args 'address)
+                                                  (assq-ref args 'port))
+                         %xapian-index
+                         (tissue-configuration-web-css (load-config)))))))
+
 (define (print-usage)
   (format #t "Usage: ~a COMMAND [OPTIONS] [ARGS]
 
@@ -199,6 +267,7 @@ COMMAND must be one of the sub-commands listed below:
   show      show the text of an issue
   repl      run a Guile script in a tissue environment
   web       export repository as website
+  run-web   run a web search service
 
 To get usage information for one of these sub-commands, run
   ~a COMMAND --help
@@ -266,6 +335,7 @@ top-level of the git repository."
                       ("show" tissue-show)
                       ("repl" tissue-repl)
                       ("web" tissue-web)
+                      ("run-web" tissue-run-web)
                       (invalid-command
                        (format (current-error-port) "Invalid command `~a'~%~%"
                                invalid-command)
diff --git a/tissue/document.scm b/tissue/document.scm
index 86fa548..2806f3b 100644
--- a/tissue/document.scm
+++ b/tissue/document.scm
@@ -41,6 +41,8 @@
             document-term-generator
             document-snippet
             print
+            document-sxml-snippet
+            document->sxml
             <file-document>
             file-document-path
             read-gemtext-document))
@@ -206,6 +208,42 @@ MSet object representing a list of search results."
       (newline)
       (newline))))
 
+(define (document-sxml-snippet document mset)
+  "Return snippet in SXML form for DOCUMENT. MSET is the xapian MSet
+object representing a list of search results."
+  ;; mset-snippet returns serialized HTML. So, we reverse it with
+  ;; html->sxml.
+  (match (html->sxml (mset-snippet mset
+                                   (document-text document)
+                                   #:length 200
+                                   #:highlight-start "<b>"
+                                   #:highlight-end "</b>"
+                                   #:stemmer (make-stem "en")))
+    (('*TOP* children ...)
+     (append-map (lambda (child)
+                   (cond
+                    ;; Add (br) if end of line.
+                    ((and (string? child)
+                          (string-suffix? "\n" child))
+                     (list (string-trim-right child #\newline)
+                           '(br)))
+                    ;; Else, return verbatim.
+                    (else
+                     (list child))))
+                 children))))
+
+(define-method (document->sxml (document <file-document>) mset)
+  "Render DOCUMENT to SXML. MSET is the xapian MSet object representing
+a list of search results."
+  `(li (@ (class "search-result"))
+       (a (@ (href ,(document-web-uri document)))
+          ,(document-title document))
+       ,@(let ((snippet (document-sxml-snippet document mset)))
+           (if snippet
+               (list `(span (@ (class "search-result-snippet"))
+                            ,@snippet))
+               (list)))))
+
 (define (read-gemtext-document file)
   "Reade gemtext document from FILE. Return a <file-document> object."
   (make <file-document>
diff --git a/tissue/issue.scm b/tissue/issue.scm
index 9b2f277..0003506 100644
--- a/tissue/issue.scm
+++ b/tissue/issue.scm
@@ -28,6 +28,7 @@
   #:use-module (oop goops)
   #:use-module (term ansi-color)
   #:use-module (git)
+  #:use-module (web uri)
   #:use-module (xapian xapian)
   #:use-module (tissue document)
   #:use-module (tissue git)
@@ -179,6 +180,62 @@
                   (else c)))
               (string-downcase str)))
 
+(define-method (document->sxml (issue <issue>) mset)
+  "Render ISSUE, an <issue> object, to SXML. MSET is the xapian MSet
+object representing a list of search results."
+  `(li (@ (class "search-result"))
+       (a (@ (href ,(document-web-uri issue)))
+          ,(document-title issue))
+       ,@(map (lambda (tag)
+                (let ((words (string-split tag (char-set #\- #\space))))
+                  `(a (@ (href ,(string-append "/search?query="
+                                               (uri-encode (string-append "tag:" tag))))
+                         (class ,(string-append "tag"
+                                                (string-append " tag-" (sanitize-string tag))
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "bug" "critical"))))
+                                                    " tag-bug"
+                                                    "")
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "progress"))))
+                                                    " tag-progress"
+                                                    "")
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "chore"))))
+                                                    " tag-chore"
+                                                    "")
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "enhancement" "feature"))))
+                                                    " tag-feature"
+                                                    ""))))
+                      ,tag)))
+              (issue-keywords issue))
+       (span (@ (class "search-result-metadata"))
+             ,(string-append
+               (format #f " opened ~a by ~a"
+                       (human-date-string (issue-created-date issue))
+                       (issue-creator issue))
+               (if (> (length (issue-posts issue))
+                      1)
+                   (format #f ", last updated ~a by ~a"
+                           (human-date-string (issue-last-updated-date issue))
+                           (issue-last-updater issue))
+                   "")
+               (if (zero? (issue-tasks issue))
+                   ""
+                   (format #f "; ~a of ~a tasks done"
+                           (issue-completed-tasks issue)
+                           (issue-tasks issue)))))
+       ,@(let ((snippet (document-sxml-snippet issue mset)))
+           (if snippet
+               (list `(span (@ (class "search-result-snippet"))
+                            ,@snippet))
+               (list)))))
+
 (define (hashtable-append! hashtable key new-values)
   "Append NEW-VALUES to the list of values KEY is associated to in
 HASHTABLE. Deduplicate the resulting list if necessary. If KEY is not
diff --git a/tissue/web/server.scm b/tissue/web/server.scm
new file mode 100644
index 0000000..c2b59e1
--- /dev/null
+++ b/tissue/web/server.scm
@@ -0,0 +1,192 @@
+;;; 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 io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #: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 (xapian xapian)
+  #:use-module (tissue conditions)
+  #:use-module (tissue document)
+  #:use-module (tissue search)
+  #:export (start-web-server))
+
+(define %css
+  "
+body {
+    max-width: 1000px;
+    margin: 0 auto;
+}
+
+form {
+    text-align: center;
+}
+
+.search-result {
+    list-style-type: none;
+    padding: 0.5em;
+}
+
+.search-result a {
+    text-decoration: none;
+    font-size: larger;
+}
+
+.search-result-metadata {
+    color: dimgray;
+    display: block;
+    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 css)
+  "Return SXML for a page with search RESULTS. CSS is a URI to a
+stylesheet."
+  `(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 "search") (name "query") (placeholder "Enter search query")))
+           (input (@ (type "submit") (value "Search"))))
+     (ul ,@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 (handler request body 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."
+  (let ((path (uri-path (request-uri request)))
+        (parameters (query-parameters (uri-query (request-uri request)))))
+    (format #t "~a ~a\n"
+            (request-method request)
+            path)
+    (cond
+     ((string=? path "/")
+      (values '((content-type . (text/html)))
+              (sxml->html (make-search-page '() css))))
+     ((string=? "/search" path)
+      (values '((content-type . (text/html)))
+              (sxml->html
+               (make-search-page
+                (call-with-database xapian-index
+                  (lambda (db)
+                    (search-map document->sxml
+                                db
+                                (list (assoc-ref parameters "query")))))
+                css))))
+     (else
+      (values (build-response #:code 404)
+              (string-append "Resource not found: "
+                             (uri->string (request-uri request))))))))
+
+(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."
+  (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 xapian-index css))
+              '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 (make-unix-domain-server-socket
+                                #:path (sockaddr:path socket-address)))))))