summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xbin/tissue70
-rw-r--r--tissue/document.scm38
-rw-r--r--tissue/issue.scm57
-rw-r--r--tissue/web/server.scm192
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)))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-21 14:21:24 +0000