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 conditions)
        (rnrs exceptions)
        (rnrs io ports)
        (srfi srfi-1)
        (srfi srfi-26)
        (srfi srfi-37)
        (srfi srfi-171)
        (srfi srfi-171 gnu)
        (ice-9 filesystem)
        (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 person)
        (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 (invalid-option opt name arg loads)
  (error "Invalid option" name))

(define (unrecognized-argument arg loads)
  (error "Unrecognized 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)
     (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)
  "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 (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 %default-config-file
  "/etc/tissue.conf")

(define (default-configuration)
  "Return the default configuration options for the `tissue pull' and
`tissue run-web' subcommands."
  (if (file-exists? %default-config-file)
      (call-with-input-file %default-config-file
        read)
      `((listen . "127.0.0.1:8080")
        (state-directory . "/var/lib/tissue")
        ;; Assume current repository as default. If there is no current
        ;; repository, do not configure any hosts.
        (hosts . ,(guard (c ((let ((git-error (condition-git-error c)))
                               (and git-error
                                    (= (git-error-code git-error)
                                       GIT_ENOTFOUND)))
                             '()))
                    `(("localhost"
                       (upstream-repository . ,(git-top-level)))))))))

(define tissue-web
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a web [OPTIONS]
Serve repositories specified in CONFIG-FILE over HTTP.

  --listen-repl=P             run REPL server listening on port or path P
  -C, --config=CONFIG-FILE    read configuration parameters from CONFIG-FILE
"
             (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)))
                                  (option '(#\C "config")
                                          #t #f
                                          (lambda (opt name config-file result)
                                            (append (call-with-input-file config-file
                                                      read)
                                                    result))))
                            invalid-option
                            unrecognized-argument
                            (default-configuration))))
       (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.
                                 (parameterize ((%current-git-repository
                                                 (repository-open
                                                  (string-append (assq-ref args 'state-directory)
                                                                 "/" name "/repository"))))
                                   (cons name
                                         (acons 'css
                                                (tissue-configuration-web-css (load-config))
                                                parameters)))))
                              (assq-ref args 'hosts))
                         (assq-ref args 'state-directory))))))

;; 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       serve one or more repositories over HTTP
  pull      pull latest from upstream repositories
  index     index files

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

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

(define (index db-path)
  "Index current repository into xapian database at DB-PATH."
  (guard (c (else (delete-file-recursively db-path)
                  (format (current-error-port)
                          "Building xapian index failed.~%")
                  (raise c)))
    (delete-file-recursively db-path)
    (call-with-writable-database db-path
      (lambda (db)
        (for-each (lambda (document)
                    (let ((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" (oid->string (reference-name->oid
                                   (current-git-repository) "HEAD")))))))

(define (pull state-directory hostname upstream-repository)
  "Pull latest from UPSTREAM-REPOSITORY into STATE-DIRECTORY for
HOSTNAME."
  (format (current-error-port)
          "Processing host ~a~%" hostname)
  (call-with-current-directory state-directory
    (lambda ()
      ;; Create host directory if it does not exist.
      (unless (file-exists? hostname)
        (mkdir hostname))
      (call-with-current-directory hostname
        (lambda ()
          (let ((repository-directory "repository"))
            (parameterize ((%current-git-repository
                            (if (file-exists? repository-directory)
                                ;; Pull latest commits from remote if
                                ;; repository is already cloned.
                                (let ((repository (repository-open repository-directory)))
                                  ;; Fetch from remote.
                                  (remote-fetch (remote-lookup repository "origin"))
                                  (let ((head (reference-symbolic-target
                                               (reference-lookup repository "HEAD")))
                                        (remote-head (reference-symbolic-target
                                                      (reference-lookup repository
                                                                        "refs/remotes/origin/HEAD"))))
                                    (if (zero? (oid-cmp (reference-name->oid repository head)
                                                        (reference-name->oid repository remote-head)))
                                        ;; HEAD is already up to date
                                        ;; with remote HEAD.
                                        (format (current-error-port)
                                                "~a is already up to date.~%"
                                                (canonicalize-path repository-directory))
                                        ;; Fast-forward local HEAD.
                                        (begin
                                          (reference-set-target!
                                           (reference-lookup repository head)
                                           (reference-name->oid repository remote-head))
                                          (format (current-error-port)
                                                  "Pulled latest changes from ~a into ~a~%"
                                                  upstream-repository
                                                  (canonicalize-path repository-directory)))))
                                  repository)
                                ;; Clone repository if it is not already.
                                (begin
                                  (let ((repository
                                         (clone upstream-repository
                                                repository-directory
                                                (clone-options #:bare? #t))))
                                    (format (current-error-port)
                                            "Cloned ~a into ~a~%"
                                            upstream-repository
                                            (canonicalize-path repository-directory))
                                    repository)))))
              (let ((config (load-config)))
                (parameterize ((%aliases (tissue-configuration-aliases config))
                               (%project-name (tissue-configuration-project config)))
                  ;; Index.
                  (let ((xapian-directory "xapian"))
                    (index xapian-directory)
                    (format (current-error-port)
                            "Indexed ~a at ~a~%"
                            (canonicalize-path repository-directory)
                            (canonicalize-path xapian-directory)))
                  ;; Build website.
                  (let ((website-directory "website"))
                    (guard (c (else (format (current-error-port)
                                            "Building website failed.~%")
                                    (raise c)))
                      (call-with-temporary-directory
                       (lambda (temporary-output-directory)
                         (build-website (git-top-level)
                                        temporary-output-directory
                                        (tissue-configuration-web-css config)
                                        (tissue-configuration-web-files config))
                         (delete-file-recursively website-directory)
                         (rename-file temporary-output-directory
                                      website-directory)
                         (chmod website-directory #o755))))
                    (format (current-error-port)
                            "Built website for ~a at ~a~%"
                            hostname
                            (canonicalize-path website-directory))))))))))))

(define tissue-pull
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a pull [HOST]
Pull latest from upstream repositories.

  -C, --config=CONFIG-FILE    read configuration parameters from CONFIG-FILE
"
             (command-line-program)))
    (args
     (let ((args (args-fold args
                            (list (option '(#\C "config")
                                          #t #f
                                          (lambda (opt name config-file result)
                                            (append (call-with-input-file config-file
                                                      read)
                                                    result))))
                            invalid-option
                            (lambda (host result)
                              (acons 'host host result))
                            (default-configuration))))
       (let ((state-directory (assq-ref args 'state-directory)))
         ;; Error out if state directory does not exist.
         (unless (file-exists? state-directory)
           (format (current-error-port)
                   "State directory ~a does not exist.~%"
                   state-directory)
           (exit #f))
         ;; Pull state for specific host, or for all hosts when none
         ;; are specified on the command-line.
         (for-each (match-lambda
                     ((hostname . parameters)
                      (when (or (not (assq-ref args 'host))
                                (string=? hostname (assq-ref args 'host)))
                        (pull state-directory
                              hostname
                              (assq-ref parameters 'upstream-repository)))))
                   (assq-ref args 'hosts)))))))

(define (main . args)
  (guard (c ((condition-git-error c)
             => (lambda (git-error)
                  (display (git-error-message git-error) (current-error-port))
                  (newline (current-error-port))
                  (exit #f))))
    (match args
      ((_ (or "-h" "--help"))
       (print-usage))
      ((_ "pull" args ...)
       (apply tissue-pull args))
      ((_ "web" args ...)
       (apply tissue-web args))
      ((_ command args ...)
       (call-with-current-directory (git-top-level)
         (lambda ()
           (let ((config (load-config)))
             (parameterize ((%aliases (tissue-configuration-aliases 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))
                   (index %xapian-index)))
               ;; Handle sub-command.
               (apply (match command
                        ("search" tissue-search)
                        ("show" tissue-show)
                        ("repl" tissue-repl)
                        ("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))