summaryrefslogtreecommitdiff
path: root/bin/tissue
diff options
context:
space:
mode:
Diffstat (limited to 'bin/tissue')
-rwxr-xr-xbin/tissue564
1 files changed, 564 insertions, 0 deletions
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))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-21 14:05:06 +0000