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-26)
        (srfi srfi-37)
        (srfi srfi-171)
        (srfi srfi-171 gnu)
        (ice-9 ftw)
        (ice-9 match)
        (ice-9 popen)
        (ice-9 regex)
        (system repl server)
        (term ansi-color)
        (git)
        (xapian wrap)
        (xapian xapian)
        (tissue conditions)
        (tissue document)
        (tissue git)
        (tissue issue)
        (tissue search)
        (tissue tissue)
        (tissue utils)
        (tissue web server)
        (tissue web static))

(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 (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-search
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a search SEARCH-QUERY
Search issues using SEARCH-QUERY.

"
             (command-line-program)))
    (args
     (call-with-database %xapian-index
       (lambda (db)
         (call-with-output-pipe
          (lambda (port)
            (search-map (cut print <> <> port) db (string-join args)))
          (or (getenv "PAGER")
              "less")
          "--raw"))))))

(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 (address->socket-address address port)
  "Convert ADDRESS and PORT to a socket address."
  (cond
   ;; IPv4
   ((string-contains address ".")
    (make-socket-address AF_INET
                         (inet-pton AF_INET address)
                         port))
   ;; IPv6
   ((string-contains address ":")
    (make-socket-address AF_INET6
                         (inet-pton AF_INET6 address)
                         port))
   ;; Unix socket
   (else
    (make-socket-address AF_UNIX address))))

(define tissue-run-web
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a run-web
Run a web search service for the current repository.

  --address=IP       run web server listening on IP address [default=127.0.0.1]
  --port=PORT        run web server listening on PORT [default=8080]
  --listen-repl=P    run REPL server listening on port or path P
"
             (command-line-program)))
    (args
     (let ((args (args-fold args
                            (list (option (list "address")
                                          #t #f
                                          (lambda (opt name arg result)
                                            (acons 'address arg result)))
                                  (option (list "port")
                                          #t #f
                                          (lambda (opt name arg result)
                                            (acons 'port (string->number arg)
                                                   result)))
                                  (option '("listen-repl")
                                          #t #f
                                          (lambda (opt name arg result)
                                            (acons 'listen-repl arg result))))
                            invalid-option
                            invalid-operand
                            ;; Default address and port
                            '((address . "127.0.0.1")
                              (port . 8080)))))
       (let ((listen-repl (assq-ref args 'listen-repl)))
         (when listen-repl
           (spawn-server (cond
                          ((string? listen-repl)
                           (format (current-error-port)
                                   "REPL server listening on port ~a~%"
                                   listen-repl)
                           (make-unix-domain-server-socket #:path listen-repl))
                          (else
                           (format (current-error-port)
                                   "REPL server listening on ~a~%"
                                   listen-repl)
                           (make-unix-domain-server-socket #:path listen-repl))))))
       (start-web-server (address->socket-address (assq-ref args 'address)
                                                  (assq-ref args 'port))
                         %xapian-index
                         (tissue-configuration-web-css (load-config)))))))

;; This is a noop, since the index is built on any tissue command. It
;; exists just for the --help usage summary.
(define tissue-index
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a index
Index files in repository.

"
             (command-line-program)))
    (() #t)))

(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
  run-web   run a web search service
  index     index files

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 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)
                                   (let* ((document (slot-set ((indexed-document-reader indexed-document))
                                                              'web-uri
                                                              (indexed-document-web-uri indexed-document)))
                                          (term-generator (document-term-generator document)))
                                     (index-text! term-generator (document-type document) #:prefix "XT")
                                     (replace-document! db
                                                        (document-id-term document)
                                                        (TermGenerator-get-document term-generator))))
                                 (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)
                      ("run-web" tissue-run-web)
                      ("index" tissue-index)
                      (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))