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 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 (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)
     (call-with-file-in-git (current-git-repository) 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))))))

(define load-config
  (memoize-thunk
   (lambda ()
     "Load configuration and return <tissue-configuration> object."
     (call-with-file-in-git (current-git-repository) "tissue.scm"
       (compose eval-string get-string-all)))))

(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 (listen->socket-address listen)
  "Convert LISTEN specification to a socket address."
  (cond
   ;; Unix socket
   ((string-prefix? "unix:" listen)
    (make-socket-address AF_UNIX
                         (string-remove-prefix "unix:" listen)))
   ;; IPv4
   ((guard (_ (else #f))
      (inet-pton AF_INET
                 (substring listen 0 (string-index-right listen #\:))))
    => (lambda (ip)
         (make-socket-address
          AF_INET ip (string->number
                      (substring listen (1+ (string-index-right listen #\:)))))))
   ;; IPv6
   (else
    (make-socket-address AF_INET6
                         (inet-pton AF_INET6
                                    (string-trim-both
                                     (substring listen 0 (string-index-right listen #\:))
                                     (char-set #\[ #\])))
                         (string->number
                          (substring listen (1+ (string-index-right listen #\:))))))))

(define tissue-run-web
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a run-web CONFIG-FILE
Run a web search service reading configuration from CONFIG-FILE.

  --listen-repl=P    run REPL server listening on port or path P
"
             (command-line-program)))
    (args
     (let ((args (args-fold args
                            (list (option '("listen-repl")
                                          #t #f
                                          (lambda (opt name arg result)
                                            (acons 'listen-repl
                                                   (or (string->number arg)
                                                       arg)
                                                   result))))
                            invalid-option
                            (lambda (config-file result)
                              (append (call-with-input-file config-file
                                        read)
                                      result))
                            ;; Default listen
                            '((listen . "127.0.0.1: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 ~a~%"
                                   listen-repl)
                           (make-unix-domain-server-socket #:path listen-repl))
                          (else
                           (format (current-error-port)
                                   "REPL server listening on port ~a~%"
                                   listen-repl)
                           (make-tcp-server-socket #:port listen-repl))))))
       (start-web-server (listen->socket-address (assq-ref args 'listen))
                         (map (match-lambda
                                ((name parameters ...)
                                 ;; Set CSS for each host.
                                 (call-with-current-directory (assq-ref parameters 'indexed-repository)
                                   (lambda ()
                                     (cons name
                                           (acons 'css
                                                  (tissue-configuration-web-css (load-config))
                                                  parameters))))))
                              (or (assq-ref args 'hosts)
                                  ;; Assume current directory as default.
                                  `(("localhost"
                                     (indexed-repository . ,(getcwd))))))
                         %xapian-index)))))

;; 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))
    ((_ "run-web" args ...)
     (apply tissue-run-web args))
    ((_ command args ...)
     (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)
                    ("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))