summaryrefslogtreecommitdiff
path: root/bin/tissue
diff options
context:
space:
mode:
Diffstat (limited to 'bin/tissue')
-rwxr-xr-xbin/tissue191
1 files changed, 94 insertions, 97 deletions
diff --git a/bin/tissue b/bin/tissue
index 4e59d73..63f3ff7 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -1,9 +1,11 @@
#!/usr/bin/env sh
-exec guile --no-auto-compile -s "$0" "$@"
+# -*- mode: scheme; -*-
+exec guile --no-auto-compile -e main -s "$0" "$@"
!#
;;; tissue --- Text based issue tracker
-;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2023 Morgan Smith <Morgan.J.Smith@outlook.com>
;;;
;;; This file is part of tissue.
;;;
@@ -47,6 +49,7 @@ exec guile --no-auto-compile -s "$0" "$@"
(tissue search)
(tissue tissue)
(tissue utils)
+ (tissue web dev)
(tissue web server)
(tissue web static))
@@ -95,8 +98,7 @@ Search issues using SEARCH-QUERY.
(lambda (port)
(search-map (cut print <> <> port) db (string-join args)))
(or (getenv "PAGER")
- "less")
- "--raw"))))))
+ "less")))))))
(define tissue-show
(match-lambda*
@@ -107,7 +109,7 @@ Show the text of FILE.
"
(command-line-program)))
((file)
- (call-with-file-in-git (current-git-repository) file
+ (call-with-input-file file
(lambda (port)
(port-transduce
(compose
@@ -149,10 +151,9 @@ Show the text of FILE.
get-line-dos-or-unix
port))))))
-(define* (load-config)
+(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)))
+ (load (canonicalize-path "tissue.scm")))
(define tissue-repl
(match-lambda*
@@ -277,44 +278,21 @@ Serve repositories specified in CONFIG-FILE over HTTP.
(parameterize ((%current-git-repository
(repository-open repository-directory)))
(cons name
- `((css . ,(tissue-configuration-web-css (load-config)))
+ `((project . ,(call-with-temporary-checkout repository-directory
+ (lambda (temporary-checkout)
+ (call-with-current-directory temporary-checkout
+ 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.
+ (format #t "Usage: ~a web-dev
+Serve 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
@@ -330,21 +308,12 @@ Serve built website and issues of current repository.
(string->number arg)
result))))
invalid-option
- (lambda (arg result)
- (acons 'website-directory arg result))
+ unrecognized-argument
'((port . 8080)))))
- (unless (assq-ref args 'website-directory)
- (raise (condition (make-user-error-condition)
- (make-message-condition "Argument WEBSITE-DIRECTORY is required."))))
(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))))))))
+ (start-dev-web-server (assq-ref args 'port)
+ %xapian-index load-config)))))
(define (print-usage)
(format #t "Usage: ~a COMMAND [OPTIONS] [ARGS]
@@ -356,8 +325,7 @@ COMMAND must be one of the sub-commands listed below:
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
+ web-dev serve website and issues of current repository
Deploy:
web serve one or more repositories over HTTP
@@ -370,7 +338,7 @@ To get usage information for one of these sub-commands, run
(command-line-program)
(command-line-program)))
-(define (index db-path)
+(define (index db-path indexed-documents)
"Index current repository into xapian database at DB-PATH."
(guard (c (else (delete-file-recursively db-path)
(format (current-error-port)
@@ -383,7 +351,7 @@ To get usage information for one of these sub-commands, run
(replace-document! db
(document-id-term document)
(TermGenerator-get-document (document-term-generator document))))
- (tissue-configuration-indexed-documents (load-config)))
+ indexed-documents)
(WritableDatabase-set-metadata
db "commit" (oid->string (reference-name->oid
(current-git-repository) "HEAD")))))))
@@ -436,36 +404,47 @@ HOSTNAME."
(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.~%")))))))))))
+ (call-with-temporary-checkout (git-top-level)
+ (lambda (temporary-repository-clone)
+ (let ((config (call-with-current-directory temporary-repository-clone
+ load-config)))
+ (parameterize ((%aliases (tissue-configuration-aliases config)))
+ ;; Add the top level of the git repository to the
+ ;; load path since there may be user-written
+ ;; modules in the repository.
+ (add-to-load-path temporary-repository-clone)
+ ;; Index.
+ (unless (file-exists? "xapian")
+ (mkdir "xapian"))
+ (let ((xapian-directory (canonicalize-path "xapian")))
+ (call-with-current-directory temporary-repository-clone
+ (cut index
+ xapian-directory
+ (tissue-configuration-indexed-documents config)))
+ (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)
+ (call-with-current-directory temporary-repository-clone
+ (cut build-website
+ temporary-output-directory
+ (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]
+ (format #t "Usage: ~a pull [OPTIONS] HOST
Pull latest from upstream repositories.
-C, --config=CONFIG-FILE read configuration parameters from CONFIG-FILE
@@ -490,18 +469,27 @@ Pull latest from upstream repositories.
"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)
+ ;; Pull state for specificied host.
+ ;; It is not a good idea to pull for all configured hosts
+ ;; when no host is specified on the command line. Since
+ ;; pulling requires executing code in each repository,
+ ;; pulling for multiple hosts in a single process can cause
+ ;; interaction of code across hosts.
+ (let ((hostname (assq-ref args 'host)))
+ (cond
+ ((assoc-ref (assq-ref args 'hosts)
+ hostname)
+ => (lambda (parameters)
+ (pull state-directory
+ hostname
+ (assq-ref parameters 'upstream-repository))))
+ (else
+ (format (current-error-port)
+ "Host ~a not found in configuration file."
+ hostname)
+ (exit #f)))))))))
+
+(define (main args)
(guard (c ((condition-git-error c)
=> (lambda (git-error)
(display (git-error-message git-error) (current-error-port))
@@ -512,6 +500,17 @@ Pull latest from upstream repositories.
(display (condition-message c) (current-error-port))
(newline (current-error-port))
(exit #f)))
+ ;; Unless LESS is already configured, pass command-line options to
+ ;; less by setting LESS. This idea is inspired by
+ ;; git. https://git-scm.com/docs/git-config#git-config-corepager
+ (unless (getenv "LESS")
+ (setenv "LESS" "FRX"))
+ ;; Add the top level of the git repository to the load path since
+ ;; there may be user-written modules in the repository.
+ (match args
+ ((_ (or "repl" "web-dev") _ ...)
+ (add-to-load-path (git-top-level)))
+ (_ #t))
(match args
((_ (or "-h" "--help"))
(print-usage))
@@ -534,13 +533,13 @@ Pull latest from upstream repositories.
(string=? (call-with-database %xapian-index
(cut Database-get-metadata <> "commit"))
current-head))
- (index %xapian-index)))
+ (index %xapian-index
+ (tissue-configuration-indexed-documents config))))
;; 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'~%~%"
@@ -549,7 +548,5 @@ Pull latest from upstream repositories.
(exit #f)))
args))))))
;; tissue is an alias for `tissue search'
- ((_)
- (main "tissue" "search")))))
-
-(apply main (command-line))
+ ((tissue)
+ (main (list tissue "search"))))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-05 12:03:59 +0000