diff options
| -rw-r--r-- | guix-build-coordinator/coordinator.scm | 22 | ||||
| -rw-r--r-- | scripts/guix-build-coordinator.in | 94 |
2 files changed, 116 insertions, 0 deletions
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm new file mode 100644 index 0000000..4246871 --- /dev/null +++ b/guix-build-coordinator/coordinator.scm @@ -0,0 +1,22 @@ +;;; Guix Build Coordinator +;;; +;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> +;;; +;;; This file is part of the guix-build-coordinator. +;;; +;;; The Guix Build Coordinator 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. +;;; +;;; The Guix Build Coordinator 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 the guix-data-service. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-build-coordinator coordinator) + ) diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in index 349073c..ad6991b 100644 --- a/scripts/guix-build-coordinator.in +++ b/scripts/guix-build-coordinator.in @@ -22,3 +22,97 @@ ;;; along with the guix-data-service. If not, see ;;; <http://www.gnu.org/licenses/>. +(use-modules (srfi srfi-37) + (ice-9 match) + (guix-build-coordinator config) + (guix-build-coordinator coordinator)) + +(define %options + ;; Specifications of the command-line options + (list (option '("pid-file") #t #f + (lambda (opt name arg result) + (alist-cons 'pid-file + arg + result))) + (option '("secret-key-base-file") #t #f + (lambda (opt name arg result) + (alist-cons 'secret-key-base + (string-trim-right + (call-with-input-file arg get-string-all)) + result))) + (option '("update-database") #f #f + (lambda (opt name _ result) + (alist-cons 'update-database #t result))) + (option '("show-error-details") #f #f + (lambda (opt name _ result) + (alist-cons 'show-error-details #t result))))) + +(define %default-options + ;; Alist of default option values + `((update-database . #f) + (show-error-details + . ,(match (getenv "GUIX_BUILD_COORDINATOR_SHOW_ERROR_DETAILS") + (#f #f) + ("" #f) + (_ #t))))) + +(define (parse-options args) + (args-fold + args %options + (lambda (opt name arg result) + (error "unrecognized option" name)) + (lambda (arg result) + (alist-cons + 'arguments + (cons arg + (or (assoc-ref result 'arguments) + '())) + (alist-delete 'arguments result))) + %default-options)) + +(setvbuf (current-output-port) 'line) +(setvbuf (current-error-port) 'line) + +(match (cdr (program-arguments)) + (("build" rest ...) + (let ((opts (parse-options rest))) + + (peek "BUILD" rest))) + ((arguments ...) + (let ((opts (parse-options arguments))) + + (when (assoc-ref opts 'update-database) + (let ((command + (list (%config 'sqitch) + "deploy" + "--db-client" (%config 'sqitch-psql) + "--chdir" (dirname (%config 'sqitch-plan)) + "--plan-file" (%config 'sqitch-plan) + (string-append "db:pg://" + (%config 'database-user) + "@" + (if (string=? (%config 'database-host) + "localhost") + "" ; This means the unix socket + ; connection will be used + (%config 'database-host)) + "/" + (%config 'database-name))))) + (simple-format #t "running command: ~A\n" + (string-join command)) + (unless (zero? (apply system* command)) + (simple-format + (current-error-port) + "error: sqitch command failed\n") + (exit 1)))) + + (let ((pid-file (assq-ref opts 'pid-file))) + (when pid-file + (call-with-output-file pid-file + (lambda (port) + (simple-format port "~A\n" (getpid)))))) + + (parameterize ((%show-error-details + (assoc-ref opts 'show-error-details))) + + (peek "OPTS" opts))))) |