Initial commit

2 files changed, 596 insertions, 0 deletions

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..cc864c8
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,32 @@
+# 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/>.
+
+prefix ?= /usr/local
+exec_prefix ?= $(prefix)
+bindir ?= $(exec_prefix)/bin
+
+scripts = $(wildcard bin/*)
+
+.PHONY: all check install
+
+all: ;
+
+check: ;
+
+install: $(scripts)
+	install -D $^ --target-directory $(bindir)
diff --git a/bin/tissue b/bin/tissue
new file mode 100755
index 0000000..f2e87e1
--- /dev/null
+++ b/bin/tissue
@@ -0,0 +1,564 @@
+#! /usr/bin/env guile
+!#
+
+;;; 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/>.
+
+(import (rnrs hashtables)
+        (rnrs io ports)
+        (srfi srfi-1)
+        (srfi srfi-9)
+        (srfi srfi-26)
+        (srfi srfi-37)
+        (srfi srfi-171)
+        (srfi srfi-171 gnu)
+        (ice-9 ftw)
+        (ice-9 match)
+        (ice-9 popen)
+        (ice-9 regex))
+
+(define (invoke program . args)
+  (unless (zero? (apply system* program args))
+    (error "Invocation of program failed" (cons program args))))
+
+(define (call-with-input-pipe proc program . args)
+  "Execute PROGRAM ARGS ... in a subprocess with a pipe to it. Call
+PROC with an input port to that pipe. Close the pipe once PROC exits,
+even if it exits non-locally. Return the value returned by PROC."
+  (let ((port #f))
+    (dynamic-wind (lambda () (set! port (apply open-pipe* OPEN_READ program args)))
+                  (cut proc port)
+                  (lambda ()
+                    (let ((return-value (status:exit-val (close-pipe port))))
+                      (unless (and return-value
+                                   (zero? return-value))
+                        (error "Invocation of program failed" (cons program args))))))))
+
+(define-record-type <issue>
+  (issue file title creator created-date created-relative-date
+         last-updater last-updated-date last-updated-relative-date
+         assigned keywords open tasks completed-tasks posts)
+  issue?
+  (file issue-file)
+  (title issue-title)
+  (creator issue-creator)
+  (created-date issue-created-date)
+  (created-relative-date issue-created-relative-date)
+  (last-updater issue-last-updater)
+  (last-updated-date issue-last-updated-date)
+  (last-updated-relative-date issue-last-updated-relative-date)
+  (assigned issue-assigned)
+  (keywords issue-keywords)
+  (open issue-open)
+  (tasks issue-tasks)
+  (completed-tasks issue-completed-tasks)
+  (posts issue-posts))
+
+(define (issues)
+  "Return a list of all issues, sorted oldest first."
+  ;; Get all gemini files except README.gmi and hidden files. Text
+  ;; editors tend to create hidden files while editing, and we want to
+  ;; avoid them.
+  (sort (call-with-input-pipe
+         (lambda (port)
+           (port-transduce
+            (tfilter-map (lambda (file)
+                           (and (string-suffix? ".gmi" file)
+                                (not (string=? (basename file) "README.gmi"))
+                                (not (string-prefix? "." (basename file)))
+                                (let* ((file-details (file-details file))
+                                       (all-keywords (hashtable-ref file-details 'keywords '())))
+                                  (issue file
+                                         ;; Fallback to filename if title has no alphabetic
+                                         ;; characters.
+                                         (let ((title (hashtable-ref file-details 'title "")))
+                                           (if (string-any char-set:letter title) title file))
+                                         (hashtable-ref file-details 'creator #f)
+                                         (hashtable-ref file-details 'created-date #f)
+                                         (hashtable-ref file-details 'created-relative-date #f)
+                                         (hashtable-ref file-details 'last-updater #f)
+                                         (hashtable-ref file-details 'last-updated-date #f)
+                                         (hashtable-ref file-details 'last-updated-relative-date #f)
+                                         (hashtable-ref file-details 'assigned '())
+                                         ;; "closed" is a special keyword to indicate
+                                         ;; the open/closed status of an issue.
+                                         (delete "closed" all-keywords)
+                                         (not (member "closed" all-keywords))
+                                         (hashtable-ref file-details 'tasks 0)
+                                         (hashtable-ref file-details 'completed-tasks 0)
+                                         (hashtable-ref file-details 'posts #f))))))
+            rcons get-line port))
+         "git" "ls-files")
+   (lambda (issue1 issue2)
+     (< (issue-created-date issue1)
+        (issue-created-date issue2)))))
+
+(define (hashtable-append! hashtable key new-values)
+  "Append NEW-VALUES to the list of values KEY is associated to in
+HASHTABLE. If KEY is not associated to any value in HASHTABLE, assume
+it is associated to the empty list."
+  (hashtable-update!
+   hashtable key (cut append <> new-values) '()))
+
+(define (comma-split str)
+  "Split string at commas, trim whitespace from both ends of the split
+strings, and return them as a list."
+  (map (cut string-trim-both <>)
+       (string-split str #\,)))
+
+(define (remove-prefix prefix str)
+  "Remove PREFIX from STR."
+  (substring str (string-length prefix)))
+
+(define (get-line-dos-or-unix port)
+  "Read line from PORT. This differs from `get-line' in (rnrs io
+ports) in that it also supports DOS line endings."
+  (let ((line (get-line port)))
+    (if (eof-object? line)
+        line
+        (string-trim-right line #\return))))
+
+(define (file-details file)
+  "Return a hashtable of details extracted from gemini FILE."
+  (let ((result (make-eq-hashtable)))
+    (call-with-input-file file
+      (lambda (port)
+        (port-transduce (tmap (lambda (line)
+                                (cond
+                                 ;; Lists with the assigned: prefix
+                                 ;; specify assignees.
+                                 ((string-prefix? "* assigned:" line)
+                                  (hashtable-append! result 'assigned
+                                                     (comma-split
+                                                      (remove-prefix "* assigned:" line))))
+                                 ;; Lists with the keywords: prefix
+                                 ;; specify keywords.
+                                 ((string-prefix? "* keywords:" line)
+                                  (hashtable-append! result 'keywords
+                                                     (comma-split
+                                                      (remove-prefix "* keywords:" line))))
+                                 ;; A more fuzzy heuristic to find keywords
+                                 ((and (string-prefix? "* " line)
+                                       ;; Is every comma-separated
+                                       ;; element two words utmost?
+                                       (every (lambda (element)
+                                                (<= (length
+                                                     (string-split element #\space))
+                                                    2))
+                                              (comma-split (remove-prefix "* " line)))
+                                       ;; Does any comma-separated
+                                       ;; element contain a potential
+                                       ;; keyword?
+                                       (any (lambda (element)
+                                              (any (lambda (keyword)
+                                                     (string-contains element keyword))
+                                                   (list "request" "bug" "critical"
+                                                         "enhancement" "progress"
+                                                         "testing" "later" "documentation"
+                                                         "help" "closed")))
+                                            (comma-split (remove-prefix "* " line))))
+                                  (hashtable-append! result 'keywords
+                                                     (comma-split
+                                                      (remove-prefix "* " line))))
+                                 ;; Checkbox lists are tasks. If the
+                                 ;; checkbox has any character other
+                                 ;; than space in it, the task is
+                                 ;; completed.
+                                 ((string-match "\\* \\[(.)\\]" line)
+                                  => (lambda (m)
+                                       (hashtable-update! result 'tasks 1+ 0)
+                                       (unless (string=? (match:substring m 1) " ")
+                                         (hashtable-update! result 'completed-tasks 1+ 0))))
+                                 ;; The first level one heading is the
+                                 ;; title.
+                                 ((string-prefix? "# " line)
+                                  (unless (hashtable-contains? result 'title)
+                                    (hashtable-set! result 'title
+                                                    (remove-prefix "# " line)))))))
+                        (const #t)
+                        get-line-dos-or-unix
+                        port)))
+    (call-with-input-pipe
+     (lambda (port)
+       (hashtable-set!
+        result 'posts
+        (port-transduce
+         (compose (tenumerate)
+                  (tmap (match-lambda
+                          ((index . line)
+                           (let ((alist (call-with-input-string line read)))
+                             (when (zero? index)
+                               (hashtable-set! result 'last-updater
+                                               (assq-ref alist 'author))
+                               (hashtable-set! result 'last-updated-date
+                                               (assq-ref alist 'author-date))
+                               (hashtable-set! result 'last-updated-relative-date
+                                               (assq-ref alist 'author-relative-date)))
+                             (hashtable-set! result 'creator
+                                             (assq-ref alist 'author))
+                             (hashtable-set! result 'created-date
+                                             (assq-ref alist 'author-date))
+                             (hashtable-set! result 'created-relative-date
+                                             (assq-ref alist 'author-relative-date)))))))
+         rcount get-line port)))
+     "git" "log"
+     (string-append "--format=format:("
+                    "(author . \"%an\")"
+                    "(author-date . %at)"
+                    "(author-relative-date . \"%ar\")"
+                    ")")
+     "--" file)
+    result))
+
+(define (git-updated-files transducer start-commit end-commit)
+  "Use TRANSDUCER to transduce over the list of files updated between
+START-COMMIT and END-COMMIT."
+  (call-with-input-pipe
+   (lambda (port)
+     (port-transduce (compose (tmap (lambda (line)
+                                      (match (string-split line #\tab)
+                                        ((status file)
+                                         (list (match status
+                                                 ("A" 'added)
+                                                 ("D" 'deleted)
+                                                 ("M" 'modified))
+                                               file)))))
+                              transducer)
+                     (const #t) get-line port))
+   "git" "diff" "--stat" "--name-status"
+   (string-append start-commit ".." end-commit)))
+
+(define rlast
+  (case-lambda
+    (() #f)
+    ((result) result)
+    ((result input) input)))
+
+(define (git-first-commit-since since)
+  "Return the hash of the first git commit since SINCE, where SINCE is
+passed verbatim to the --since argument of `git log'. Return #f if
+there is no such commit."
+  (call-with-input-pipe
+   (lambda (port)
+     (port-transduce (tmap identity)
+                     rlast
+                     get-line
+                     port))
+   "git" "log" "--format=format:%H" "--since" since))
+
+;;;
+;;; 3 bit colors using ANSI escape codes
+;;;
+
+(define (color code str)
+  "Return STR within ANSI escape CODE, thus rendering it in color in a
+terminal."
+  (format #f "~a[~am~a~a[0m" #\esc code str #\esc))
+
+(define bold (cut color 1 <>))
+
+(define red (cut color 31 <>))
+(define green (cut color 32 <>))
+(define yellow (cut color 33 <>))
+(define blue (cut color 34 <>))
+(define magenta (cut color 35 <>))
+(define cyan (cut color 36 <>))
+
+(define red-background (cut color 41 <>))
+(define green-background (cut color 42 <>))
+(define yellow-background (cut color 43 <>))
+(define blue-background (cut color 44 <>))
+(define magenta-background (cut color 45 <>))
+(define cyan-background (cut color 46 <>))
+
+(define (invalid-option opt name arg loads)
+  (error "Invalid option" name))
+
+(define (invalid-operand arg loads)
+  (error "Invalid argument" arg))
+
+(define (command-line-program)
+  "Return the name, that is arg0, of the command-line program invoked
+to run tissue."
+  (match (command-line)
+    ((program _ ...) program)))
+
+(define tissue-news
+  (match-lambda*
+    (("--help")
+     (format #t "Usage: ~a news
+List recent updates.
+
+  --since=DATE  show updates more recent than DATE
+
+"
+             (command-line-program)))
+    (args
+     (let ((args (args-fold args
+                            (list (option (list "since") #t #f
+                                          (lambda (opt name arg loads)
+                                            (acons 'since arg loads))))
+                            invalid-option
+                            invalid-operand
+                            '())))
+       (unless (assq 'since args)
+         (error "--since argument required"))
+       (git-updated-files (tlog (match-lambda*
+                                  ((_ (status file))
+                                   (format #t ((case status
+                                                 ((added) green)
+                                                 ((deleted) red)
+                                                 ((modified) magenta))
+                                               "~a (~a)~%")
+                                           file
+                                           (case status
+                                             ((added) "new")
+                                             ((deleted) "deleted")
+                                             ((modified) "updated"))))))
+                          (or (git-first-commit-since (assq-ref args 'since))
+                              "HEAD")
+                          "HEAD")))))
+
+(define (print-issue issue-number issue)
+  "Print ISSUE with number ISSUE-NUMBER."
+  (display (magenta (issue-title issue)))
+  ;; Highlight keywords containing "bug" or "critical" as whole words
+  ;; in red. Else, highlight in blue.
+  (unless (null? (issue-keywords issue))
+    (display " ")
+    (display (string-join
+              (map (lambda (keyword)
+                     ((cond
+                       ((not (null? (lset-intersection
+                                     string=?
+                                     (string-split keyword #\space)
+                                     (list "bug" "critical"))))
+                        red-background)
+                       (else blue-background))
+                      (string-append " " keyword " ")))
+                   (issue-keywords issue))
+              " ")))
+  (unless (null? (issue-assigned issue))
+    (display (green (string-append " (assigned: "
+                                   (string-join (issue-assigned issue)
+                                                ", ")
+                                   ")"))))
+  (when (> (issue-posts issue) 1)
+    (display (string-append " ["
+                            (number->string (issue-posts issue))
+                            " posts]")))
+  (newline)
+  (display (string-append
+            (cyan (string-append "#" (number->string issue-number)))
+            " opened "
+            (cyan (issue-created-relative-date issue))
+            " by "
+            (cyan (issue-creator issue))))
+  (when (> (issue-posts issue) 1)
+    (display (string-append (cyan ",")
+                            " last updated "
+                            (cyan (issue-last-updated-relative-date issue))
+                            " by "
+                            (cyan (issue-last-updater issue)))))
+  (unless (zero? (issue-tasks issue))
+    (display (string-append (cyan "; ")
+                            (number->string (issue-completed-tasks issue))
+                            "/"
+                            (number->string (issue-tasks issue))
+                            " tasks done")))
+  (newline))
+
+(define (print-issue-to-gemtext issue-number issue)
+  "Print ISSUE with number ISSUE-NUMBER to gemtext."
+  (format #t "# ~a" (issue-title issue))
+  (unless (null? (issue-keywords issue))
+    (format #t " [~a]"
+            (string-join (issue-keywords issue)
+                         ", ")))
+  (unless (null? (issue-assigned issue))
+    (format #t " (assigned: ~a)"
+            (string-join (issue-assigned issue)
+                         ", ")))
+  (when (> (issue-posts issue) 1)
+    (format #t " [~a posts]" (issue-posts issue)))
+  (newline)
+  (format #t "~a opened ~a by ~a"
+          issue-number
+          (issue-created-relative-date issue)
+          (issue-creator issue))
+  (when (> (issue-posts issue) 1)
+    (format #t ", last updated ~a by ~a"
+            (issue-last-updated-relative-date issue)
+            (issue-last-updater issue)))
+  (unless (zero? (issue-tasks issue))
+    (format #t "; ~a/~a tasks done"
+            (issue-completed-tasks issue)
+            (issue-tasks issue)))
+  (newline)
+  (newline))
+
+(define tissue-list
+  (match-lambda*
+    (("--help")
+     (format #t "Usage: ~a list [OPTIONS]
+List issues.
+
+  --assigned=ASSIGNED    only list issues assigned to ASSIGNED
+  --format=FORMAT        output in FORMAT (either text or gemtext, and text by default)
+
+"
+             (command-line-program)))
+    (args
+     (let ((args (args-fold args
+                            (list (option (list "assigned") #t #f
+                                          (lambda (opt name arg loads)
+                                            (acons 'assigned arg loads)))
+                                  (option (list "format") #t #f
+                                          (lambda (opt name arg loads)
+                                            (acons 'format
+                                                   (cond
+                                                    ((string=? arg "text") 'text)
+                                                    ((string=? arg "gemtext") 'gemtext)
+                                                    (else (error "Unknown format" arg)))
+                                                   loads))))
+                            invalid-option
+                            invalid-operand
+                            '((format . text)))))
+       (format #t "~%total ~a~%"
+               (list-transduce (compose (tenumerate 1)
+                                        (tfilter (match-lambda
+                                                   ((_ . issue)
+                                                    (and (issue-open issue)
+                                                         (or (not (assq 'assigned args))
+                                                             (member (assq-ref args 'assigned)
+                                                                     (issue-assigned issue)))))))
+                                        (tlog (match-lambda*
+                                                ((_ (index . issue))
+                                                 ((case (assq-ref args 'format)
+                                                    ((text) print-issue)
+                                                    ((gemtext) print-issue-to-gemtext))
+                                                  index issue)))))
+                               rcount
+                               (issues)))))))
+
+(define tissue-edit
+  (match-lambda*
+    (("--help")
+     (format #t "Usage: ~a edit ISSUE-NUMBER
+Start $EDITOR to edit issue #ISSUE-NUMBER.
+
+"
+             (command-line-program)))
+    ((issue-number)
+     (unless (getenv "EDITOR")
+       (error "Please set the EDITOR environment variable to your favorite editor. For example,
+export EDITOR=emacsclient"))
+     (invoke (getenv "EDITOR")
+             (issue-file (list-ref (issues)
+                                   (1- (string->number issue-number))))))))
+
+(define tissue-show
+  (match-lambda*
+    (("--help")
+     (format #t "Usage: ~a show ISSUE-NUMBER
+Show the text of issue #ISSUE-NUMBER.
+
+"
+             (command-line-program)))
+    ((issue-number)
+     (call-with-input-file (issue-file (list-ref (issues)
+                                                 (1- (string->number issue-number))))
+       (lambda (port)
+         (port-transduce
+          (compose
+           ;; Detect preformatted text blocks.
+           (tfold (match-lambda*
+                    (((pre? . _) line)
+                     (cons (if (string-prefix? "```" line)
+                               (not pre?)
+                               pre?)
+                           line)))
+                  (cons #f #f))
+           (tmap (lambda (pre?+line)
+                   (match pre?+line
+                     ((pre? . line)
+                      (cond
+                       ;; Print headlines in bold.
+                       ((string-prefix? "#" line)
+                        (display (bold line)))
+                       ;; Print lists in cyan.
+                       ((string-prefix? "*" line)
+                        (display (cyan line)))
+                       ;; Print links in cyan, but only the actual
+                       ;; link, and not the => prefix or the label.
+                       ((string-match "^(=>[ \t]*)([^ ]*)([^\n]*)" line)
+                        => (lambda (m)
+                             (display (match:substring m 1))
+                             (display (cyan (match:substring m 2)))
+                             (display (match:substring m 3))))
+                       ;; Print preformatted text backticks in
+                       ;; magenta.
+                       ((string-prefix? "```" line)
+                        (display (magenta line)))
+                       (else
+                        ;; If part of preformatted block, print in
+                        ;; magenta. Else, print in default color.
+                        (display (if pre? (magenta line) line))))))
+                   (newline))))
+          (const #t)
+          get-line-dos-or-unix
+          port))))))
+
+(define (print-usage)
+  (format #t "Usage: ~a COMMAND [OPTIONS] [ARGS]
+
+COMMAND must be one of the sub-commands listed below:
+
+  list      list issues
+  edit      edit an issue
+  show      show the text of an issue
+  news      list recent updates
+
+To get usage information for one of these sub-commands, run
+  ~a COMMAND --help
+
+"
+          (command-line-program)
+          (command-line-program)))
+
+(define main
+  (match-lambda*
+    ((_ (or "-h" "--help"))
+     (print-usage))
+    ((_ command args ...)
+     (apply (match command
+              ("news" tissue-news)
+              ("list" tissue-list)
+              ("edit" tissue-edit)
+              ("show" tissue-show)
+              (invalid-command
+               (format (current-error-port) "Invalid command `~a'~%~%"
+                       invalid-command)
+               (print-usage)
+               (exit #f)))
+            args))
+    ;; tissue is an alias for `tissue list'
+    ((_)
+     (tissue-list))))
+
+(apply main (command-line))