#!@GUILE@ --no-auto-compile -*- scheme -*- -*- geiser-scheme-implementation: guile -*- !# ;;; Guix Build Coordinator ;;; ;;; Copyright © 2020 Christopher Baines ;;; ;;; 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 ;;; . (use-modules (srfi srfi-1) (srfi srfi-37) (ice-9 match) ((guix ui) #:select (read/eval)) (guix-build-coordinator hooks) (guix-build-coordinator config) (guix-build-coordinator datastore) (guix-build-coordinator coordinator) (guix-build-coordinator agent-messaging http)) (define %base-options ;; Specifications of the command-line options (list (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 '("database") #t #f (lambda (opt name arg result) (alist-cons 'database arg 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 %base-option-defaults ;; Alist of default option values `((update-database . #f) (database . "sqlite://guix_build_coordinator.db") (port . 8745) (host . "0.0.0.0") (show-error-details . ,(match (getenv "GUIX_BUILD_COORDINATOR_SHOW_ERROR_DETAILS") (#f #f) ("" #f) (_ #t))))) (define %build-options (list (option '("priority") #t #f (lambda (opt name arg result) (alist-cons 'priority (string->number arg) result))) (option '("ignore-if-build-for-derivation-exists") #f #f (lambda (opt name _ result) (alist-cons 'ignore-if-build-for-derivation-exists #t result))) (option '("ensure-all-related-derivations-have-builds") #f #f (lambda (opt name _ result) (alist-cons 'ensure-all-related-derivations-have-builds #t result))) (option '("defer-allocation") #f #f (lambda (opt name _ result) (alist-cons 'defer-allocation #t result))))) (define %build-option-defaults `((priority . 0) (ignore-if-build-for-derivation-exists . #f) (ensure-all-related-derivations-have-builds . #f) (defer-allocation . #f))) (define %service-options (list (option '("pid-file") #t #f (lambda (opt name arg result) (alist-cons 'pid-file arg result))) (option '("port") #t #f (lambda (opt name arg result) (alist-cons 'port (string->number arg) (alist-delete 'port result)))) (option '("host") #t #f (lambda (opt name arg result) (alist-cons 'host arg (alist-delete 'host result)))) (option '("build-success-hook") #t #f (lambda (opt name arg result) (alist-cons 'build-success-hook (read/eval arg) (alist-delete 'build-success-hook result)))) (option '("build-failure-hook") #t #f (lambda (opt name arg result) (alist-cons 'build-failure-hook (read/eval arg) (alist-delete 'build-failure-hook result)))) (option '("build-missing-inputs-hook") #t #f (lambda (opt name arg result) (alist-cons 'build-missing-inputs-hook (read/eval arg) (alist-delete 'build-missing-inputs-hook result)))))) (define %service-option-defaults ;; Alist of default option values `((port . 8745) (host . "0.0.0.0") (build-success-hook . ,default-build-success-hook) (build-failure-hook . ,default-build-failure-hook) (build-missing-inputs-hook . ,default-build-missing-inputs-hook))) (define %agent-options (list (option '("uuid") #t #f (lambda (opt name arg result) (alist-cons 'uuid arg result))) (option '("description") #t #f (lambda (opt name arg result) (alist-cons 'description arg result))))) (define (parse-options options defaults 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))) defaults)) (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) (match (cdr (program-arguments)) (("build" rest ...) (let ((opts (parse-options (append %build-options %base-options) (append %build-option-defaults %base-option-defaults) rest))) (match (assq-ref opts 'arguments) ((derivation-file) (let ((datastore (database-uri->datastore (assq-ref opts 'database)))) (when (assq-ref opts 'ignore-if-build-for-derivation-exists) (let ((builds-for-derivation (datastore-list-builds-for-derivation datastore derivation-file))) (unless (null? builds-for-derivation) (simple-format #t "there are already ~A builds for ~A, skipping\n" (length builds-for-derivation) derivation-file) (exit 0)))) (let ((uuid (submit-build datastore derivation-file #:priority (assq-ref opts 'priority) #:defer-allocation? (assq-ref opts 'defer-allocation) #:ensure-all-related-derivations-have-builds? (assq-ref opts 'ensure-all-related-derivations-have-builds)))) (simple-format #t "build submitted as ~A\n" uuid))))))) (("agent" "new" rest ...) (let ((opts (parse-options (append %agent-options %base-options) %base-option-defaults rest))) (let ((uuid (new-agent (database-uri->datastore (assq-ref opts 'database)) #:requested-uuid (assq-ref opts 'uuid) #:description (assq-ref opts 'description)))) (simple-format #t "agent created as as ~A\n" uuid)))) (("agent" id "password" "new" rest ...) (let ((opts (parse-options %base-options %base-option-defaults rest))) (let ((password (new-agent-password (database-uri->datastore (assq-ref opts 'database)) #:agent id))) (simple-format #t "new password: ~A\n" password)))) (("agent" "list" rest ...) (let ((opts (parse-options %base-options %base-option-defaults rest))) (for-each (lambda (agent) (simple-format #t "~A: ~A\n" (assq-ref agent 'uuid) (or (assq-ref agent 'description) "(no description)"))) (datastore-list-agents (database-uri->datastore (assq-ref opts 'database)))))) ((arguments ...) (let* ((opts (parse-options (append %service-options %base-options) (append %service-option-defaults %base-option-defaults) arguments)) (datastore (database-uri->datastore (assq-ref opts 'database))) (hooks `((build-success . ,(assq-ref opts 'build-success-hook)) (build-failure . ,(assq-ref opts 'build-failure-hook)) (build-missing-inputs . ,(assq-ref opts 'build-missing-inputs-hook))))) (when (assoc-ref opts 'update-database) (datastore-update datastore)) (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))) (simple-format #t "listening on ~A:~A\n" (assq-ref opts 'host) (assq-ref opts 'port)) (http-agent-messaging-start-server (assq-ref opts 'port) (assq-ref opts 'host) (assq-ref opts 'secret-key-base) datastore hooks)))))