diff options
author | Arun Isaac | 2022-06-29 00:18:18 +0530 |
---|---|---|
committer | Arun Isaac | 2022-06-29 00:18:18 +0530 |
commit | a8023a99111233fec4b6050c6de3130097e84483 (patch) | |
tree | 0614a2f25b75b69ddd0a928b4bd4f63ad265514e /tissue | |
parent | 58dcd6b052a61229e0ceb021076a1f450a80aea9 (diff) | |
download | tissue-a8023a99111233fec4b6050c6de3130097e84483.tar.gz tissue-a8023a99111233fec4b6050c6de3130097e84483.tar.lz tissue-a8023a99111233fec4b6050c6de3130097e84483.zip |
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.
Diffstat (limited to 'tissue')
-rw-r--r-- | tissue/document.scm | 38 | ||||
-rw-r--r-- | tissue/issue.scm | 57 | ||||
-rw-r--r-- | tissue/web/server.scm | 192 |
3 files changed, 287 insertions, 0 deletions
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))))))) |