diff options
Diffstat (limited to 'bin/tissue')
| -rwxr-xr-x | bin/tissue | 265 |
1 files changed, 150 insertions, 115 deletions
@@ -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* @@ -241,6 +242,49 @@ port." socket-or-port) (make-tcp-server-socket #:port socket-or-port))))) +(define (load-config-from-repository repository-directory) + "Load configuration from @var{repository-directory}, and return a +@code{<tissue-configuration>} object." + (parameterize ((%current-git-repository + (repository-open repository-directory))) + (call-with-temporary-checkout repository-directory + (lambda (temporary-checkout) + (call-with-current-directory temporary-checkout + load-config))))) + +(define (normalize-project state-directory project) + "Normalize @var{project} from @file{tissue.conf} adding in default and +extra parameters for convenient processing later on. +@var{state-directory} is the tissue state directory." + (match project + ((name . parameters) + (let ((repository-directory + (string-append state-directory "/" name "/repository"))) + (cons name + `((base-path . ,(or (assq-ref parameters 'base-path) + (string-append "/" name))) + (project . ,(load-config-from-repository repository-directory)) + (repository-directory . ,repository-directory) + (website-directory . ,(string-append state-directory + "/" name "/website")) + (xapian-directory . ,(string-append state-directory + "/" name "/xapian")) + ,@parameters)))))) + +(define (normalize-host state-directory host) + "Normalize @var{host} from @file{tissue.conf} adding in default and +extra parameters for convenient processing later on. +@var{state-directory} is the tissue state directory." + (match host + ((host-name . host-parameters) + ;; Add repository directory, website directory, xapian directory + ;; settings for each host. + (cons host-name + `((projects + ,@(map (cut normalize-project state-directory <>) + (assq-ref host-parameters 'projects))) + ,@host-parameters))))) + (define tissue-web (match-lambda* (("--help") @@ -266,58 +310,20 @@ Serve repositories specified in CONFIG-FILE over HTTP. (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)))))) + (map (cut normalize-host + (assq-ref args 'state-directory) + <>) (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 + --base-path=PATH serve website at PATH " (command-line-program))) (args @@ -328,23 +334,21 @@ Serve built website and issues of current repository. (lambda (opt name arg result) (acons 'port (string->number arg) + result))) + (option '(#\b "base-path") + #t #f + (lambda (opt name arg result) + (acons 'base-path arg result)))) invalid-option - (lambda (arg result) - (acons 'website-directory arg result)) - '((port . 8080))))) - (unless (assq-ref args 'website-directory) - (raise (condition (make-user-error-condition) - (make-message-condition "Argument WEBSITE-DIRECTORY is required.")))) + unrecognized-argument + '((port . 8080) + (base-path . "/"))))) (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) + (assq-ref args 'base-path) + %xapian-index load-config))))) (define (print-usage) (format #t "Usage: ~a COMMAND [OPTIONS] [ARGS] @@ -356,8 +360,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 +373,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 +386,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 +439,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] PROJECT Pull latest from upstream repositories. -C, --config=CONFIG-FILE read configuration parameters from CONFIG-FILE @@ -480,8 +494,8 @@ Pull latest from upstream repositories. read) result)))) invalid-option - (lambda (host result) - (acons 'host host result)) + (lambda (project result) + (acons 'project project result)) (default-configuration)))) (let ((state-directory (assq-ref args 'state-directory))) ;; Error out if state directory does not exist. @@ -490,18 +504,30 @@ 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 project. + ;; It is not a good idea to pull for all configured projects + ;; when no project is specified on the command line. Since + ;; pulling requires executing code in each repository, + ;; pulling for multiple projects in a single process can + ;; cause interaction of code across projects. + (let ((project-name (assq-ref args 'project))) + (cond + ((assoc-ref (append-map (match-lambda + ((_ . parameters) + (assq-ref parameters 'projects))) + (assq-ref args 'hosts)) + project-name) + => (lambda (parameters) + (pull state-directory + project-name + (assq-ref parameters 'upstream-repository)))) + (else + (format (current-error-port) + "Project ~a not found in configuration file." + project-name) + (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 +538,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 +571,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 +586,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")))))) |