diff options
Diffstat (limited to 'bin')
| -rwxr-xr-x | bin/tissue | 564 |
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)) |