diff options
| -rwxr-xr-x | bin/tissue | 70 | ||||
| -rw-r--r-- | tissue/document.scm | 38 | ||||
| -rw-r--r-- | tissue/issue.scm | 57 | ||||
| -rw-r--r-- | tissue/web/server.scm | 192 |
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))))))) |