path: root/bin/tissue

#!/usr/bin/env sh
exec guile --no-auto-compile -s "$0" "$@"
!#

;;; 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 exceptions)
        (rnrs io ports)
        (srfi srfi-1)
        (srfi srfi-9)
        (srfi srfi-19)
        (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)
        (term ansi-color)
        (git)
        (xapian wrap)
        (xapian xapian)
        (tissue conditions)
        (prefix (tissue document) doc:)
        (tissue git)
        (tissue issue)
        (tissue tissue)
        (tissue utils)
        (tissue web))

(define %state-directory
  ".tissue")

(define %xapian-index
  (string-append %state-directory "/xapian"))

(define-record-type <indexed-document>
  (indexed-document reader web-uri)
  indexed-document?
  ;; A thunk that returns a document object (currently either an
  ;; <issue> or a <document> object), presumably by reading it from a
  ;; file or other source
  (reader indexed-document-reader)
  ;; A string URI linking to this document on the web
  (web-uri indexed-document-web-uri))

(define (human-date-string date)
  "Return a human readable rendering of DATE."
  (let ((elapsed-time
         (time-second
          (time-difference (date->time-monotonic (current-date))
                           (date->time-monotonic date)))))
    (cond
     ((< elapsed-time (* 2 60))
      (format #f "~a seconds ago" elapsed-time))
     ((< elapsed-time (* 2 60 60))
      (format #f "~a minutes ago" (round (/ elapsed-time 60))))
     ((< elapsed-time (* 2 24 60 60))
      (format #f "~a hours ago" (round (/ elapsed-time 60 60))))
     ((< elapsed-time (* 2 7 24 60 60))
      (format #f "~a days ago" (round (/ elapsed-time 60 60 24))))
     ((< elapsed-time (* 2 30 24 60 60))
      (format #f "~a weeks ago" (round (/ elapsed-time 60 60 24 7))))
     (else
      (format #f "on ~a" (date->string date "~b ~d ~Y"))))))

(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 (print-issue issue)
  "Print ISSUE."
  (let ((number-of-posts (length (issue-posts issue))))
    (display (colorize-string (issue-title issue) 'MAGENTA 'UNDERLINE))
    (unless (null? (issue-keywords issue))
      (display " ")
      (display (string-join (map (cut colorize-string <> 'ON-BLUE)
                                 (issue-keywords issue))
                            " ")))
    (unless (null? (issue-assigned issue))
      (display (colorize-string (string-append " (assigned: "
                                               (string-join (issue-assigned issue)
                                                            ", ")
                                               ")")
                                'GREEN)))
    (when (> number-of-posts 1)
      (display (string-append " ["
                              (number->string number-of-posts)
                              " posts]")))
    (newline)
    (display (colorize-string (issue-file issue) 'YELLOW))
    (newline)
    (display (string-append
              "opened "
              (colorize-string (human-date-string (issue-created-date issue)) 'CYAN)
              " by "
              (colorize-string (issue-creator issue) 'CYAN)))
    (when (> number-of-posts 1)
      (display (string-append (colorize-string "," 'CYAN)
                              " last updated "
                              (colorize-string (human-date-string (issue-last-updated-date issue))
                                               'CYAN)
                              " by "
                              (colorize-string (issue-last-updater issue)
                                               'CYAN))))
    (unless (zero? (issue-tasks issue))
      (display (string-append (colorize-string "; " 'CYAN)
                              (number->string (issue-completed-tasks issue))
                              "/"
                              (number->string (issue-tasks issue))
                              " tasks done")))
    (newline)
    (newline)))

(define (print-issue-to-gemtext issue)
  "Print ISSUE to gemtext."
  (let ((number-of-posts (length (issue-posts issue))))
    (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 (> number-of-posts 1)
      (format #t " [~a posts]" number-of-posts))
    (newline)
    (format #t "opened ~a by ~a"
            (human-date-string (issue-created-date issue))
            (issue-creator issue))
    (when (> number-of-posts 1)
      (format #t ", last updated ~a by ~a"
              (human-date-string (issue-last-updated-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 (print-document document)
  "Print DOCUMENT, an <issue> or <document> object."
  ((cond
    ((issue? document) print-issue)
    ((doc:document? document) doc:print-document)
    (else (raise (unknown-document-type-violation document))))
   document))

(define (alist->document alist)
  "Convert ALIST to an <issue> or <document> object."
  ((case (assq-ref alist 'type)
     ((issue) alist->issue)
     ((document) doc:alist->document)
     (else (raise (unknown-document-type-violation alist))))
   alist))

(define (document->text document)
  "Return the text of DOCUMENT, an <issue> or <document> object."
  (call-with-input-file
      ((cond
        ((issue? document) issue-file)
        ((doc:document? document) doc:document-file)
        (else (raise (unknown-document-type-violation document))))
       document)
    get-string-all))

(define tissue-search
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a search SEARCH-QUERY
Search issues using SEARCH-QUERY.

"))
    (args
     (call-with-database %xapian-index
       (lambda (db)
         (let* ((stemmer (make-stem "en"))
                (query (parse-query
                        ;; When query does not mention type or state,
                        ;; assume is:open. Assuming is:open is
                        ;; implicitly assuming type:issue since only
                        ;; issues can have is:open.
                        (if (every string-null? args)
                            "is:open"
                            (string-join (if (any (lambda (query-string)
                                                    (or (string-contains-ci query-string "type:")
                                                        (string-contains-ci query-string "is:")))
                                                  args)
                                             args
                                             (cons "is:open" args))
                                         " AND "))
                        #:stemmer stemmer
                        #:prefixes '(("type" . "XT")
                                     ("title" . "S")
                                     ("creator" . "A")
                                     ("last-updater" . "XA")
                                     ("updater" . "XA")
                                     ("assigned" . "XI")
                                     ("keyword" . "K")
                                     ("tag" . "K")
                                     ("is" . "XS")))))
           (format #t "total ~a~%"
                   (mset-fold (lambda (item count)
                                (let ((document (call-with-input-string (document-data (mset-item-document item))
                                                  (compose alist->document read))))
                                  (print-document document)
                                  (let ((snippet (mset-snippet (MSetIterator-mset-get item)
                                                               (document->text document)
                                                               #:length 200
                                                               #:highlight-start (color 'BOLD 'ON-RED)
                                                               #:highlight-end (color 'RESET)
                                                               #:stemmer stemmer)))
                                    (unless (string-null? snippet)
                                      (display snippet)
                                      (newline)
                                      (newline)))
                                  (1+ count)))
                              0
                              (enquire-mset (enquire db query)
                                            #:maximum-items (database-document-count db))))))))))

(define tissue-show
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a show FILE
Show the text of FILE.

"
             (command-line-program)))
    ((file)
     ;; Files may be renamed or deleted, but not committed. Therefore,
     ;; only read the file if it exists.
     (if (file-exists? file)
         (call-with-input-file file
           (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 (colorize-string line 'BOLD)))
                           ;; Print lists in cyan.
                           ((string-prefix? "*" line)
                            (display (colorize-string line 'CYAN)))
                           ;; 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 (colorize-string (match:substring m 2) 'CYAN))
                                 (display (match:substring m 3))))
                           ;; Print preformatted text backticks in
                           ;; magenta.
                           ((string-prefix? "```" line)
                            (display (colorize-string line 'MAGENTA)))
                           (else
                            ;; If part of preformatted block, print in
                            ;; magenta. Else, print in default color.
                            (display (if pre? (colorize-string line 'MAGENTA) line))))))
                       (newline))))
              (const #t)
              get-line-dos-or-unix
              port)))
         (raise (issue-file-not-found-error file))))))

(define load-config
  (memoize-thunk
   (lambda ()
     "Load configuration and return <tissue-configuration> object."
     (load (canonicalize-path "tissue.scm")))))

(define tissue-repl
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a repl [-- FILE ARGS...]
In a tissue execution environment, run FILE as a Guile script with
command-line arguments ARGS.

"
             (command-line-program)))
    (args
     (let ((args (args-fold args
                            '()
                            invalid-option
                            (lambda (arg result)
                              (acons 'script arg result))
                            '())))
       (match (reverse (filter-map (match-lambda
                                     (('script . arg) arg)
                                     (_ #f))
                                   args))
         ((script args ...)
          (set-program-arguments (cons script args))
          (load (canonicalize-path script))))))))

(define tissue-web
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a web OUTPUT-DIRECTORY
Export the repository as a website to OUTPUT-DIRECTORY.

"
             (command-line-program)))
    ((output-directory)
     (parameterize ((%project-name (tissue-configuration-project (load-config))))
       (build-website (getcwd)
                      output-directory
                      (tissue-configuration-web-css (load-config))
                      (tissue-configuration-web-files (load-config)))))))

(define (print-usage)
  (format #t "Usage: ~a COMMAND [OPTIONS] [ARGS]

COMMAND must be one of the sub-commands listed below:

  search    search issues
  show      show the text of an issue
  repl      run a Guile script in a tissue environment
  web       export repository as website

To get usage information for one of these sub-commands, run
  ~a COMMAND --help

"
          (command-line-program)
          (command-line-program)))

(define (delete-xapian-index)
  "Delete xapian index if it exists. Current directory must be at the
top-level of the git repository."
  (when (file-exists? %xapian-index)
    (for-each (lambda (file)
                (delete-file (string-append %xapian-index "/" file)))
              (scandir %xapian-index
                       (negate (cut member <> (list "." "..")))))
    (rmdir %xapian-index)))

(define (index-document db document)
  "Index DOCUMENT, an <issue> or <document> object, in writable xapian
DB."
  ((cond
    ((issue? document) index-issue)
    ((doc:document? document) doc:index-document)
    (else (raise (unknown-document-type-violation document))))
   db document))

(define main
  (match-lambda*
    ((_ (or "-h" "--help"))
     (print-usage))
    ((_ command args ...)
     (guard (c ((issue-file-not-found-error? c)
                (display (string-append "No such file or directory: "
                                        (issue-file-not-found-error-issue-file c))
                         (current-error-port))
                (newline (current-error-port))
                (exit #f)))
       (call-with-current-directory (git-top-level)
         (lambda ()
           (parameterize ((%aliases (tissue-configuration-aliases (load-config))))
             ;; Create hidden tissue directory unless it exists.
             (unless (file-exists? %state-directory)
               (mkdir %state-directory))
             ;; Ensure index exists rebuilding it if it is stale.
             (let ((current-head
                    (oid->string (reference-name->oid
                                  (current-git-repository) "HEAD"))))
               (unless (and (file-exists? %xapian-index)
                            (string=? (call-with-database %xapian-index
                                        (cut Database-get-metadata <> "commit"))
                                      current-head))
                 (guard (c (else (delete-xapian-index)
                                 (display "Building xapian index failed."
                                          (current-error-port))
                                 (raise c)))
                   (delete-xapian-index)
                   (call-with-writable-database %xapian-index
                     (lambda (db)
                       (for-each (lambda (indexed-document)
                                   (index-document db ((indexed-document-reader indexed-document))))
                                 (tissue-configuration-indexed-documents (load-config)))
                       (WritableDatabase-set-metadata db "commit" current-head))))))
             ;; Handle sub-command.
             (apply (match command
                      ("search" tissue-search)
                      ("show" tissue-show)
                      ("repl" tissue-repl)
                      ("web" tissue-web)
                      (invalid-command
                       (format (current-error-port) "Invalid command `~a'~%~%"
                               invalid-command)
                       (print-usage)
                       (exit #f)))
                    args))))))
    ;; tissue is an alias for `tissue search'
    ((_)
     (main "tissue" "search"))))

(apply main (command-line))