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 commit)
        (tissue file-document)
        (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 listen-repl-option
  (option '("listen-repl")
          #t #f
          (lambda (opt name arg result)
            (acons 'listen-repl
                   (or (string->number arg)
                       arg)
                   result))))

(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-condition-type &user-error-condition &serious
  make-user-error-condition user-error-condition?)

(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 (start-repl socket-or-port)
  "Start REPL listening on SOCKET-OR-PORT. Assume SOCKET-OR-PORT is a
Unix socket if it is a string. Else, assume it is a numerical TCP
port."
  (spawn-server
   (cond
    ((string? socket-or-port)
     (format (current-error-port)
             "REPL server listening on ~a~%"
             socket-or-port)
     (make-unix-domain-server-socket #:path socket-or-port))
    (else
     (format (current-error-port)
             "REPL server listening on port ~a~%"
             socket-or-port)
     (make-tcp-server-socket #:port socket-or-port)))))

(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 listen-repl-option
                                  (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))))
       (when (assq-ref args 'listen-repl)
         (start-repl (assq-ref args 'listen-repl)))
       (start-web-server (listen->socket-address (assq-ref args 'listen))
                         (map (match-lambda
                                ((name parameters ...)
                                 ;; Add CSS, repository directory,
                                 ;; website directory, xapian
                                 ;; directory settings for each host.
                                 (let* ((state-directory (assq-ref args 'state-directory))
                                        (repository-directory
                                         (string-append state-directory "/" name "/repository")))
                                   (parameterize ((%current-git-repository
                                                   (repository-open repository-directory)))
                                     (cons name
                                           `((css . ,(tissue-configuration-web-css (load-config)))
                                             (repository-directory . ,repository-directory)
                                             (website-directory . ,(string-append state-directory "/" name "/website"))
                                             (xapian-directory . ,(string-append state-directory "/" name "/xapian"))
                                             ,@parameters))))))
                              (assq-ref args 'hosts)))))))

(define tissue-web-build
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a web-build WEBSITE-DIRECTORY
Build website of current repository.
"
             (command-line-program)))
    ((website-directory)
     (let ((config (load-config)))
       (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))
          (dirname website-directory))))
     (format (current-error-port)
             "Built website.~%"))))

(define tissue-web-dev
  (match-lambda*
    (("--help")
     (format #t "Usage: ~a web-dev WEBSITE-DIRECTORY
Serve built website and issues of current repository.

  --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 listen-repl-option
                                  (option '("port")
                                          #t #f
                                          (lambda (opt name arg result)
                                            (acons 'port
                                                   (string->number arg)
                                                   result))))
                            invalid-option
                            (lambda (arg result)
                              (acons 'website-directory arg result))
                            '((port . 8080)))))
       (when (assq-ref args 'listen-repl)
         (start-repl (assq-ref args 'listen-repl)))
       (start-web-server (make-socket-address
                          AF_INET (inet-pton AF_INET "127.0.0.1") (assq-ref args 'port))
                         `(("localhost"
                            (css . ,(tissue-configuration-web-css (load-config)))
                            (repository-directory . ,(repository-directory (current-git-repository)))
                            (website-directory . ,(assq-ref args 'website-directory))
                            (xapian-directory . ,%xapian-index))))))))

(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

Develop:
  web-build build website of current repository
  web-dev   serve built website and issues of current repository

Deploy:
  web       serve one or more repositories over HTTP
  pull      pull latest from upstream repositories

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)
                    (replace-document! db
                                       (document-id-term document)
                                       (TermGenerator-get-document (document-term-generator document))))
                  (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)
                                                "Repository is already up to date.~%")
                                        ;; 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.~%"))))
                                  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 upstream repository.~%")
                                    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 latest changes.~%"))
                  ;; 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.~%")))))))))))

(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)
                        ("web-build" tissue-web-build)
                        ("web-dev" tissue-web-dev)
                        (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))