tissue: Support exporting issues to the web.

* tissue/web.scm: New file.

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)))))))