diff options
| -rw-r--r-- | tissue/web.scm | 237 |
1 files changed, 237 insertions, 0 deletions
diff --git a/tissue/web.scm b/tissue/web.scm new file mode 100644 index 0000000..715e5c7 --- /dev/null +++ b/tissue/web.scm @@ -0,0 +1,237 @@ +;;; 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) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-28) + #:use-module (srfi srfi-171) + #:use-module (skribilo ast) + #:use-module (skribilo engine) + #:use-module (skribilo evaluator) + #:use-module (skribilo lib) + #:use-module (skribilo package base) + #:use-module (skribilo reader) + #:use-module (skribilo utils keywords) + #:use-module (skribilo writer) + #:use-module (sxml simple) + #:use-module (tissue issue) + #:use-module (tissue utils) + #:export (issue-listing + build-website)) + +(define %tags-path + (make-parameter #f)) + +(define (mkdir-p directory) + "Create DIRECTORY and all its parents." + (unless (or (string=? directory "/") + (string=? directory ".")) + (mkdir-p (dirname directory))) + (unless (file-exists? directory) + (mkdir directory))) + +(define (replace-extension file new-extension) + "Return a new filename where the extension of FILE is replaced with +NEW-EXTENSION." + (string-append (substring file 0 (1+ (string-index-right file #\.))) + new-extension)) + +(define-markup (issue-list-item #:rest opts + #:key (ident #f) (class "issue-list-item") + (file #f) (title #f) + (creator #f) (created-date #f) (created-relative-date #f) + (last-updater #f) (last-updated-date #f) (last-updated-relative-date #f) + (assigned #f) (keywords #f) (open #f) + (tasks #f) (completed-tasks #f) + (posts #f)) + (new container + (markup 'issue-list-item) + (ident (or ident (symbol->string (gensym "issue-list-item")))) + (class class) + (loc &invocation-location) + (required-options '(#:file #:title + #:creator #:created-date #:created-relative-date + #:last-updater #:last-updated-date #:last-updated-relative-date + #:assigned #:keywords #:open + #:tasks #:completed-tasks + #:posts)) + (options `((#:file ,file) + (#:title ,title) + (#:creator ,creator) + (#:created-date ,created-date) + (#:created-relative-date ,created-relative-date) + (#:last-updater ,last-updater) + (#:last-updated-date ,last-updated-date) + (#:last-updated-relative-date ,last-updated-relative-date) + (#:assigned ,assigned) + (#:keywords ,keywords) + (#:open ,open) + (#:tasks ,tasks) + (#:completed-tasks ,completed-tasks) + (#:posts ,posts) + ,@(the-options opts #:ident #:class + #:file #:title + #:creator #:created-date #:created-relative-date + #:last-updater #:last-updated-date #:last-updated-relative-date + #:assigned #:keywords #:open + #:tasks #:completed-tasks + #:posts))) + (body (the-body opts)))) + +(define (issue-list-item-markup-writer-action markup engine) + (sxml->xml + `(li (@ (class "issue-list-item")) + (a (@ (href ,(replace-extension + (string-append "/" (markup-option markup #:file)) + "html"))) + ,(markup-option markup #:title)) + ,@(map (lambda (tag) + (let ((words (string-split tag (char-set #\- #\space)))) + `(a (@ (href ,(string-append (%tags-path) "/" tag ".html")) + (class ,(string-append "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))) + (markup-option markup #:keywords)) + (span (@ (class "issue-list-item-metadata")) + ,(string-append + (format " opened ~a by ~a" + (markup-option markup #:created-relative-date) + (markup-option markup #:creator)) + (if (> (markup-option markup #:posts) 1) + (format ", last updated ~a by ~a" + (markup-option markup #:last-updated-relative-date) + (markup-option markup #:last-updater)) + "")))))) + +(markup-writer 'issue-list-item + (find-engine 'html) + #:options '(#:file #:title + #:creator #:created-date #:created-relative-date + #:last-updater #:last-updated-date #:last-updated-relative-date + #:assigned #:keywords #:open + #:tasks #:completed-tasks + #:posts) + #:action issue-list-item-markup-writer-action) + +(define* (issue-listing #:optional (issues (reverse (issues)))) + "Return an issue listing for ISSUES, a list of <issue> objects. By +default, all issues are listed newest first." + (itemize (map (lambda (issue) + (issue-list-item #:file (issue-file issue) + #:title (issue-title issue) + #:creator (issue-creator issue) + #:created-date (issue-created-date issue) + #:created-relative-date (issue-created-relative-date issue) + #:last-updater (issue-last-updater issue) + #:last-updated-date (issue-last-updated-date issue) + #:last-updated-relative-date (issue-last-updated-relative-date issue) + #:assigned (issue-assigned issue) + #:keywords (issue-keywords issue) + #:open (issue-open issue) + #:tasks (issue-tasks issue) + #:completed-tasks (issue-completed-tasks issue) + #:posts (issue-posts issue))) + issues))) + +(define* (build-issue-listing issues output-file #:key title) + "Write an issues listing page listing ISSUES to OUTPUT-FILE." + (mkdir-p (dirname output-file)) + (with-output-to-file output-file + (cut evaluate-document + (document #:title title + (issue-listing issues)) + (find-engine 'html)))) + +;; TODO: Use guile-filesystem. +(define* (build-website output-directory #:key title (tags-path "/tags")) + "Export current git repository to OUTPUT-DIRECTORY as a website. + +TITLE is the title to use head of the generated HTML, among other +places. TAGS-PATH is the path relative to the document root where the +per-tag issue listings are put. It must begin with a /. If it is #f, +per-tag issue listings are not generated." + (mkdir-p output-directory) + ;; Publish files. + (call-with-input-pipe + (lambda (port) + (port-transduce + (tmap (lambda (input-file) + (unless (string-prefix? "." (basename input-file)) + (let* ((relative-input-file input-file) + (output-file (string-append output-directory "/" + (if (or (string-suffix? ".gmi" relative-input-file) + (string-suffix? ".skb" relative-input-file)) + (replace-extension relative-input-file "html") + relative-input-file)))) + (display (format "~a -> ~a~%" input-file output-file)) + (mkdir-p (dirname output-file)) + (if (or (string-suffix? ".gmi" input-file) + (string-suffix? ".skb" input-file)) + (with-output-to-file output-file + (cut evaluate-document + (call-with-input-file input-file + (cut evaluate-ast-from-port <> + #:reader ((reader:make (lookup-reader + (cond + ((string-suffix? ".gmi" input-file) + 'gemtext) + ((string-suffix? ".skb" input-file) + 'skribe))))))) + (find-engine 'html))) + (copy-file input-file output-file)))))) + rcons get-line port)) + "git" "ls-files") + (parameterize ((%tags-path tags-path)) + ;; Publish index. + (let ((output-file (string-append output-directory "/index.html"))) + (display (format "~a~%" output-file)) + (build-issue-listing (reverse (issues)) output-file + #:title title)) + ;; Publish per-tag listings. + (when tags-path + (for-each (lambda (tag) + (let ((output-file (string-append output-directory + tags-path "/" tag ".html"))) + (display (format "tag: ~a -> ~a~%" tag output-file)) + (build-issue-listing (reverse (filter (lambda (issue) + (member tag (issue-keywords issue))) + (issues))) + output-file + #:title title))) + (delete-duplicates (append-map issue-keywords (issues))))))) |