#!/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 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
  web-build build website of current repository
  web-dev   serve built website and issues of current repository
  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))