#!@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 ;;; . (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) (let ((columns (string->number (or (getenv "COLUMNS") "")))) (setenv "COLUMNS" (number->string (if columns (max 256 columns) 256)))) (use-modules (srfi srfi-1) (srfi srfi-9 gnu) (srfi srfi-19) (srfi srfi-37) (srfi srfi-43) (srfi srfi-71) (ice-9 match) (ice-9 streams) (ice-9 exceptions) (ice-9 suspendable-ports) (web uri) (fibers) (fibers scheduler) (fibers conditions) (prometheus) ((guix ui) #:select (read/eval)) (guix progress) (guix derivations) (guix-build-coordinator hooks) (guix-build-coordinator utils) (guix-build-coordinator config) (guix-build-coordinator datastore) (guix-build-coordinator coordinator) (guix-build-coordinator build-allocator) (guix-build-coordinator client-communication)) (install-suspendable-ports!) ;; TODO Work around this causing problems with backtraces ;; https://github.com/wingo/fibers/issues/76 (set-record-type-printer! (@@ (fibers scheduler) ) (lambda (scheduler port) (display "#" port))) (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 . ,(string-append "sqlite://" (getcwd) "/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 %client-options (list (option '("coordinator") #t #f (lambda (opt name arg result) (alist-cons 'coordinator arg (alist-delete 'coordinator result)))))) (define %client-option-defaults '((coordinator . "http://localhost:8746"))) (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 '("ignore-if-build-for-outputs-exists") #f #f (lambda (opt name _ result) (alist-cons 'ignore-if-build-for-outputs-exists #t result))) (option '("ensure-all-related-derivation-outputs-have-builds") #f #f (lambda (opt name _ result) (alist-cons 'ensure-all-related-derivation-outputs-have-builds #t result))) (option '("derivation-substitute-urls") #t #f (lambda (opt name arg result) (alist-cons 'derivation-substitute-urls (string-split arg #\space) result))) (option '("tag") #t #f (lambda (opt name arg result) (alist-cons 'tags (cons (match (string-split arg #\=) ((key value) `((key . ,key) (value . ,value)))) (or (assq-ref result 'tags) '())) (alist-delete 'tags result)))) (option '("defer-until") #t #f (lambda (opt name arg result) (alist-cons 'defer-until (string->date arg "~Y-~m-~d ~H:~M:~S") result))))) (define %build-option-defaults `((priority . 0) (ignore-if-build-for-derivation-exists . #f) (ignore-if-build-for-outputs-exists . #f) (ensure-all-related-derivation-outputs-have-builds . #f) (tags . ()))) (define %setup-failure-options (list (option '("agent-id") #t #f (lambda (opt name arg result) (alist-cons 'agent-id arg (alist-delete 'agent-id result)))))) (define %setup-failure-option-defaults `((agent-id . #f))) (define %common-build-filtering-options (list (option '("tag") #t #f (lambda (opt name arg result) (alist-cons 'tags (cons (match (string-split arg #\=) ((key value) `((key . ,key) (value . ,value))) ((key) key)) (or (assq-ref result 'tags) '())) (alist-delete 'tags result)))) (option '("not-tag") #t #f (lambda (opt name arg result) (alist-cons 'not-tags (cons (match (string-split arg #\=) ((key value) `((key . ,key) (value . ,value))) ((key) key)) (or (assq-ref result 'not-tags) '())) (alist-delete 'not-tags result)))) (option '("system") #t #f (lambda (opt name arg result) (alist-cons 'systems (cons arg (or (assq-ref result 'systems) '())) (alist-delete 'systems result)))) (option '("not-system") #t #f (lambda (opt name arg result) (alist-cons 'not-systems (cons arg (or (assq-ref result 'not-systems) '())) (alist-delete 'not-systems result)))) (option '("processed") #t #f (lambda (opt name arg result) (alist-cons 'processed (string=? arg "true") result))) (option '("canceled") #t #f (lambda (opt name arg result) (alist-cons 'canceled (string=? arg "true") result))) (option '("priority-gt") #t #f (lambda (opt name arg result) (alist-cons 'priority-> (string->number arg) result))) (option '("priority-lt") #t #f (lambda (opt name arg result) (alist-cons 'priority-< (string->number arg) result))) (option '("build-relationship") #t #f (lambda (opt name arg result) (alist-cons 'relationship (string->symbol arg) result))))) (define %common-build-filtering-option-defaults `((tags . ()) (not-tags . ()) (systems . ()) (not-systems . ()) (processed . unset) (canceled . unset) (priority-> . unset) (priority-< . unset) (relationship . unset))) (define %builds-list-options (cons* (option '("after-id") #t #f (lambda (opt name arg result) (alist-cons 'after-id arg result))) (option '("limit") #t #f (lambda (opt name arg result) (alist-cons 'limit (string->number arg) result))) %common-build-filtering-options)) (define %builds-list-option-defaults `(,@%common-build-filtering-option-defaults)) (define %build-cancel-options (list (option '("tag") #t #f (lambda (opt name arg result) (alist-cons 'tags (cons (match (string-split arg #\=) ((key value) `((key . ,key) (value . ,value))) ((key) key)) (or (assq-ref result 'tags) '())) (alist-delete 'tags result)))) (option '("not-tag") #t #f (lambda (opt name arg result) (alist-cons 'not-tags (cons (match (string-split arg #\=) ((key value) `((key . ,key) (value . ,value))) ((key) key)) (or (assq-ref result 'not-tags) '())) (alist-delete 'not-tags result)))) (option '("system") #t #f (lambda (opt name arg result) (alist-cons 'systems (cons arg (or (assq-ref result 'systems) '())) (alist-delete 'systems result)))) (option '("not-system") #t #f (lambda (opt name arg result) (alist-cons 'not-systems (cons arg (or (assq-ref result 'not-systems) '())) (alist-delete 'not-systems result)))) (option '("skip-updating-derived-priorities") #f #f (lambda (opt name _ result) (alist-cons 'skip-updating-derived-priorities #t result))) (option '("ignore-if-build-required-by-another") #t #f (lambda (opt name arg result) (alist-cons 'ignore-if-build-required-by-another (string=? arg "true") result))) (option '("build-relationship") #t #f (lambda (opt name arg result) (alist-cons 'relationship (string->symbol arg) result))))) (define %build-cancel-option-defaults `((tags . ()) (not-tags . ()) (systems . ()) (not-systems . ()) (ignore-if-build-required-by-another . #t) (relationship . no-dependent-builds))) (define %build-update-priority-options (cons* (option '("new-priority") #t #f (lambda (opt name arg result) (alist-cons 'new-priority (string->number arg) (alist-delete 'new-priority result)))) (option '("override-derived-priority") #t #f (lambda (opt name arg result) (alist-cons 'override-derived-priority (string->number arg) (alist-delete 'override-derived-priority result)))) (option '("skip-updating-derived-priorities") #f #f (lambda (opt name _ result) (alist-cons 'skip-updating-derived-priorities #t result))) %common-build-filtering-options)) (define %build-update-priority-option-defaults %common-build-filtering-option-defaults) (define %build-show-blocking-options (list (option '("system") #t #f (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result)))) (option '("include-canceled") #t #f (lambda (opt name arg result) (alist-cons 'include-canceled? (string=? arg "true") result))))) (define %build-show-blocking-option-defaults '((include-cancelled? . #f))) (define %agent-tag-options (list (option '("tag") #t #f (lambda (opt name arg result) (alist-cons 'tags (cons (match (string-split arg #\=) ((key value) `((key . ,key) (value . ,value)))) (or (assq-ref result 'tags) '())) (alist-delete 'tags result)))) (option '("remove-tag") #t #f (lambda (opt name arg result) (alist-cons 'remove-tags (cons (match (string-split arg #\=) ((key value) `((key . ,key) (value . ,value))) ((key) key)) (or (assq-ref result 'remove-tags) '())) (alist-delete 'remove-tags result)))))) (define %agent-tag-option-defaults `((tags . ()) (remove-tags . ()))) (define %service-options (append (list (option '("pid-file") #t #f (lambda (opt name arg result) (alist-cons 'pid-file arg result))) (option '("agent-communication") #t #f (lambda (opt name arg result) (alist-cons 'agent-communication (string->uri arg) (alist-delete 'agent-communication result)))) (option '("client-communication") #t #f (lambda (opt name arg result) (alist-cons 'client-communication (string->uri arg) (alist-delete 'client-communication result)))) (option '("allocation-strategy") #t #f (lambda (opt name arg result) (alist-cons 'allocation-strategy (or (assoc-ref `(("basic" . ,basic-build-allocation-strategy) ("derivation-ordered" . ,derivation-ordered-build-allocation-strategy)) arg) (begin (simple-format (current-error-port) "error: ~A is not a known allocation strategy\n" arg) (exit 1))) result)))) (append-map (lambda (hook) (list (option (list (simple-format #f "~A-hook" hook)) #t #f (lambda (opt name arg result) (alist-cons (symbol-append hook '-hook) (read/eval arg) (alist-delete (symbol-append hook '-hook) result)))) (option (list (simple-format #f "~A-hook-threads" hook)) #t #f (lambda (opt name arg result) (alist-cons 'parallel-hooks `((,hook . ,(string->number arg)) ,@(or (assq-ref result 'parallel-hooks) '())) (alist-delete 'parallel-hooks result)))))) %known-hooks))) (define %service-option-defaults ;; Alist of default option values `((agent-communication . ,%default-agent-uri) (client-communication . ,%default-client-uri) (allocation-strategy . ,basic-build-allocation-strategy))) (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)) (match (cdr (program-arguments)) (("build" "show" rest ...) (let ((opts (parse-options %base-options (append %base-option-defaults %client-option-defaults) rest))) (define (display-build build-details) (simple-format #t "derivation name: ~A priority: ~A processed?: ~A canceled?: ~A " (assoc-ref build-details "derivation-name") (if (assoc-ref build-details "processed") (assoc-ref build-details "priority") (simple-format #f "~A\nderived priority: ~A" (assoc-ref build-details "priority") (assoc-ref build-details "derived-priority"))) (if (assoc-ref build-details "processed") "yes" "no") (if (assoc-ref build-details "canceled") "yes" "no")) (simple-format #t "tags:\n~A" (string-join (map (lambda (tag) (let ((key (assoc-ref tag "key")) (val (assoc-ref tag "value"))) (string-append " " key ": " val))) (vector->list (assoc-ref build-details "tags"))) "\n")) (newline) (let ((derivation-inputs (vector->list (assoc-ref build-details "derivation-inputs")))) (unless (null? derivation-inputs) (display "\ninputs:\n") (for-each (lambda (derivation-input-details) (simple-format #t " - ~A:\n" (assoc-ref derivation-input-details "output")) (for-each (lambda (output-build) (simple-format #t " - ~A: ~A\n" (assoc-ref output-build "uuid") (or (assoc-ref output-build "result") "unknown"))) (vector->list (assoc-ref derivation-input-details "builds")))) derivation-inputs))) (let ((setup-failures (vector->list (assoc-ref build-details "setup-failures")))) (unless (null? setup-failures) (display "\nsetup failures:\n") (for-each (lambda (setup-failure) (simple-format #t " - agent: ~A failure reason: ~A " (assoc-ref setup-failure "agent-id") (assoc-ref setup-failure "failure-reason")) (when (string=? (assoc-ref setup-failure "failure-reason") "missing_inputs") (simple-format #t " missing inputs:\n") (for-each (lambda (missing-input-details) (simple-format #t " - ~A\n" (assoc-ref missing-input-details "missing-input")) (for-each (lambda (missing-input-build) (simple-format #t " - ~A~A\n" (assoc-ref missing-input-build "uuid") (if (assoc-ref missing-input-build "processed") " (finished)" ""))) (vector->list (assoc-ref missing-input-details "builds")))) (vector->list (assoc-ref setup-failure "missing-inputs"))) (newline))) setup-failures)))) (match (assq-ref opts 'arguments) ((build-id) (let ((response (request-build-details (assq-ref opts 'coordinator) build-id))) (display-build `(("uuid" . ,build-id) ,@response))))))) (("build" "list" rest ...) (let ((opts (parse-options (append %base-options %client-options %builds-list-options) (append %base-option-defaults %client-option-defaults %builds-list-option-defaults) rest))) (fold-builds (assq-ref opts 'coordinator) (lambda (build-details _) (simple-format (current-output-port) "id: ~A derivation: ~A processed: ~A canceled: ~A priority: ~A tags: ~A \n" (assoc-ref build-details "uuid") (assoc-ref build-details "derivation-name") (if (assoc-ref build-details "processed") "true" "false") (if (assoc-ref build-details "canceled") "true" "false") (assoc-ref build-details "priority") (string-join (map (lambda (tag) (let ((key (assoc-ref tag "key")) (val (assoc-ref tag "value"))) (string-append " " key ": " val))) (vector->list (assoc-ref build-details "tags"))) "\n")) #f) #f #:tags (assq-ref opts 'tags) #:not-tags (assq-ref opts 'not-tags) #:systems (assq-ref opts 'systems) #:not-systems (assq-ref opts 'not-systems) #:processed (assq-ref opts 'processed) #:canceled (assq-ref opts 'canceled) #:priority-> (assq-ref opts 'priority->) #:priority-< (assq-ref opts 'priority-<) #:relationship (assq-ref opts 'relationship) #:after-id (assq-ref opts 'after-id) #:limit (assq-ref opts 'limit)))) (("build" "show-blocking" rest ...) (let ((opts (parse-options (append %base-options %client-options %build-show-blocking-options) (append %base-option-defaults %client-option-defaults %build-show-blocking-option-defaults) rest))) (let ((response (request-failed-builds-with-blocking-count-list (assq-ref opts 'coordinator) (assq-ref opts 'system) #:include-cancelled? (assq-ref opts 'include-cancelled?)))) (for-each (lambda (build) (format #t "~a (~5d): ~a~%" (assoc-ref build "uuid") (assoc-ref build "blocked_count") (assoc-ref build "derivation_name"))) (vector->list (assoc-ref response "builds")))))) (("build" "cancel" rest ...) (let ((opts (parse-options (append %client-options %base-options %build-cancel-options) (append %client-option-defaults %base-option-defaults %build-cancel-option-defaults) rest))) (define (get-batch) (simple-format (current-error-port) "requesting matching builds\n") (force-output (current-error-port)) (fold-builds (assq-ref opts 'coordinator) (lambda (build-details result) (cons (assoc-ref build-details "uuid") result)) '() #:tags (assq-ref opts 'tags) #:not-tags (assq-ref opts 'not-tags) #:systems (assq-ref opts 'systems) #:not-systems (assq-ref opts 'not-systems) #:processed #f #:canceled #f #:relationship (assq-ref opts 'relationship))) (match (assq-ref opts 'arguments) (#f (let loop ((matching-builds (get-batch))) (let ((count (length matching-builds))) (if (= 0 count) (simple-format (current-error-port) "finished cancelling builds matching criteria\n") (begin (simple-format (current-error-port) "cancelling ~A builds matching criteria\n" count) (call-with-progress-reporter (progress-reporter/bar count (simple-format #f "canceling ~A builds" count) (current-error-port)) (lambda (report) (for-each (lambda (id) (let ((result (retry-on-error (lambda () (send-cancel-build-request (assq-ref opts 'coordinator) id #:skip-updating-derived-priorities? (assq-ref opts 'skip-updating-derived-priorities) #:ignore-if-build-required-by-another? (assq-ref opts 'ignore-if-build-required-by-another))) #:times 6 #:delay 5))) (unless (string=? (assoc-ref result "result") "build-canceled") (simple-format #t "~A\n" (assoc-ref result "result")))) (report)) matching-builds))) (loop (get-batch))))))) ((build-id) (let ((result (send-cancel-build-request (assq-ref opts 'coordinator) build-id #:skip-updating-derived-priorities? (assq-ref opts 'skip-updating-derived-priorities) #:ignore-if-build-required-by-another? (assq-ref opts 'ignore-if-build-required-by-another)))) (simple-format #t "~A\n" (assoc-ref result "result"))))))) (("build" "update-priority" rest ...) (let ((opts (parse-options (append %client-options %base-options %build-update-priority-options) (append %client-option-defaults %base-option-defaults %build-update-priority-option-defaults) rest))) (define (find-matching-builds) (fold-builds (assq-ref opts 'coordinator) (lambda (build-details result) (cons (assoc-ref build-details "uuid") result)) '() #:tags (assq-ref opts 'tags) #:not-tags (assq-ref opts 'not-tags) #:systems (assq-ref opts 'systems) #:not-systems (assq-ref opts 'not-systems) #:processed #f #:canceled #f #:priority-> (assq-ref opts 'priority->) #:priority-< (assq-ref opts 'priority-<))) (match (assq-ref opts 'arguments) (#f (simple-format (current-error-port) "requesting matching builds") (force-output (current-error-port)) (let* ((matching-builds (find-matching-builds)) (count (length matching-builds))) (simple-format (current-error-port) "\nfound ~A builds matching criteria\n" count) (call-with-progress-reporter (progress-reporter/bar count (simple-format #f "updating priorities for ~A builds" count) (current-error-port)) (lambda (report) (for-each (lambda (id) (retry-on-error (lambda () (send-update-build-priority-request (assq-ref opts 'coordinator) id (assq-ref opts 'new-priority) #:skip-updating-derived-priorities? (assq-ref opts 'skip-updating-derived-priorities) #:override-derived-priority (assq-ref opts 'override-derived-priority)) (report)) #:times 6 #:delay 5 #:ignore (lambda (exn) (member (assoc-ref (exception-message exn) "error") '("build-already-canceled" "build-already-processed"))))) matching-builds))))) ((build-id) (send-update-build-priority-request (assq-ref opts 'coordinator) build-id (assq-ref opts 'new-priority)))))) (("build" rest ...) (let ((opts (parse-options (append %build-options %base-options) (append %build-option-defaults %client-option-defaults %base-option-defaults) rest))) (match (assq-ref opts 'arguments) ((derivation-file) (let ((response (send-submit-build-request (assq-ref opts 'coordinator) derivation-file (assq-ref opts 'derivation-substitute-urls) #f ; TODO requested uuid (assq-ref opts 'priority) (assq-ref opts 'ignore-if-build-for-derivation-exists) (assq-ref opts 'ignore-if-build-for-outputs-exists) (assq-ref opts 'ensure-all-related-derivation-outputs-have-builds) (assq-ref opts 'tags) #:defer-until (assq-ref opts 'defer-until)))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response (simple-format #t "skipped: ~A\n" no-build-submitted-response) (simple-format #t "build submitted as ~A\n" (assoc-ref response "build-submitted"))))))))) (("output" rest ...) (let ((opts (parse-options (append %base-options %client-options) (append %base-option-defaults %client-option-defaults) rest))) (match (assq-ref opts 'arguments) ((output) (let ((details (request-output-details (assq-ref opts 'coordinator) output))) (for-each (lambda (build) (simple-format #t "~A:\n result: ~A\n processed: ~A\n priority: ~A\n derivation: ~A\n\n" (assoc-ref build "uuid") (assoc-ref build "result") (assoc-ref build "processed") (assoc-ref build "priority") (assoc-ref build "derivation"))) (vector->list (assoc-ref details "builds")))))))) (("agent" "new" rest ...) (let ((opts (parse-options (append %agent-options %client-options %base-options) (append %client-option-defaults %base-option-defaults) rest))) (let ((response (send-create-agent-request (assq-ref opts 'coordinator) #:requested-uuid (assq-ref opts 'uuid) #:description (assq-ref opts 'description)))) (simple-format #t "agent created as as ~A\n" (assoc-ref response "agent-id"))))) (("agent" agent-id "activate" rest ...) (let ((opts (parse-options %base-options (append %client-option-defaults %base-option-defaults) rest))) (let ((response (send-agent-set-active-request (assq-ref opts 'coordinator) agent-id #true))) (if (string=? (assoc-ref response "result") "success") (display "successfully activated agent\n") (display "error activating agent\n"))))) (("agent" agent-id "deactivate" rest ...) (let ((opts (parse-options %base-options (append %client-option-defaults %base-option-defaults) rest))) (let ((response (send-agent-set-active-request (assq-ref opts 'coordinator) agent-id #false))) (if (string=? (assoc-ref response "result") "success") (display "successfully deactivated agent\n") (display "error activating agent\n"))))) (("agent" agent-id "password" "new" rest ...) (let ((opts (parse-options %base-options (append %client-option-defaults %base-option-defaults) rest))) (let ((response (send-create-agent-password-request (assq-ref opts 'coordinator) agent-id))) (simple-format #t "new password: ~A\n" (assoc-ref response "new-password"))))) (("agent" agent-id "tags" rest ...) (let ((opts (parse-options (append %agent-tag-options %client-options %base-options) (append %agent-tag-option-defaults %client-option-defaults %base-option-defaults) rest))) (let ((agent-details (request-agent-details (assq-ref opts 'coordinator) agent-id))) (let* ((initial-tags (vector-fold (lambda (_ result tag) (cons `((key . ,(assoc-ref tag "key")) (value . ,(assoc-ref tag "value"))) result)) '() (assoc-ref agent-details "tags"))) (new-tags (remove (match-lambda ((('key . key) ('value . val)) (any (match-lambda ((('key . k) ('value . v)) (and (string=? key k) (string=? val v))) (k (string=? key k))) (assq-ref opts 'remove-tags)))) (append initial-tags (assq-ref opts 'tags))))) (let ((response (send-replace-agent-tags-request (assq-ref opts 'coordinator) agent-id (list->vector new-tags)))) (if (equal? initial-tags new-tags) (simple-format #t "tags unchanged:\n") (simple-format #t "changed tags to:\n")) (for-each (match-lambda ((('key . key) ('value . value)) (simple-format #t " - ~A: ~A\n" key value))) new-tags)))))) (("agent" agent-id "build-allocation-plan" rest ...) (let ((opts (parse-options (append %client-options %base-options) (append %client-option-defaults %base-option-defaults) rest))) (let ((build-allocation-plan (assoc-ref (request-agent-build-allocation-plan (assq-ref opts 'coordinator) agent-id) "build_allocation_plan"))) (vector-for-each (lambda (index build) (simple-format #t "~A: ~A\n" index (assoc-ref build "uuid")) (simple-format #t " derivation name: ~A\n" (assoc-ref build "derivation_name")) (simple-format #t " system: ~A\n" (assoc-ref build "system")) (simple-format #t " priority: ~A\n" (assoc-ref build "priority")) (simple-format #t " derived priority: ~A\n" (assoc-ref build "derived_priority")) (let ((tags (assoc-ref build "tags"))) (unless (= 0 (vector-length tags)) (simple-format #t " tags:\n") (vector-for-each (lambda (_ tag) (let ((key (assoc-ref tag "key")) (value (assoc-ref tag "value"))) (simple-format #t " - ~A: ~A\n" key value))) tags))) (newline)) build-allocation-plan)))) (("agent" "list" rest ...) (let ((opts (parse-options %base-options (append %base-option-defaults %client-option-defaults) rest))) (for-each (lambda (agent) (simple-format #t "~A: ~A\n" (assoc-ref agent "uuid") (or (assoc-ref agent "name") "(no name)")) (and=> (assoc-ref agent "description") (lambda (description) (simple-format #t " description:\n ~A" description))) (and=> (assoc "active" agent) (match-lambda (("active" . active?) (simple-format #t " active?: ~A\n" (if active? "true" "false"))))) (let ((allocated-builds (vector->list (assoc-ref agent "allocated_builds")))) (simple-format #t " ~A allocated builds:\n" (length allocated-builds)) (for-each (lambda (allocated-build) (simple-format #t " - ~A: ~A\n" (assoc-ref allocated-build "uuid") (or (assoc-ref allocated-build "derivation_name") (assoc-ref allocated-build "derivation-name")))) allocated-builds)) (simple-format #t " requested systems:\n") (for-each (lambda (requested-system) (simple-format #t " - ~A\n" requested-system)) (vector->list (assoc-ref agent "requested_systems"))) (let ((tags (assoc-ref agent "tags"))) (simple-format #t " tags:\n") (for-each (lambda (tag) (let ((key (assoc-ref tag "key")) (value (assoc-ref tag "value"))) (simple-format #t " - ~A: ~A\n" key value))) (vector->list tags))) (newline)) (vector->list (assoc-ref (request-agents-list (assq-ref opts 'coordinator)) "agents"))))) (("setup-failures" "list" rest ...) (let ((opts (parse-options (append %client-options %base-options %setup-failure-options) (append %client-option-defaults %base-option-defaults %setup-failure-option-defaults) rest))) (for-each (match-lambda ((build-id . setup-failures) (for-each (lambda (setup-failure) (simple-format #t "~A:\n" (assoc-ref setup-failure "id")) (simple-format #t " build-id: ~A\n" build-id) (simple-format #t " agent-id: ~A\n" (assoc-ref setup-failure "agent-id")) (simple-format #t " failure-reason: ~A\n" (assoc-ref setup-failure "failure-reason")) (newline)) (vector->list setup-failures)))) (assoc-ref (request-setup-failures (assq-ref opts 'coordinator) #:agent-id (assq-ref opts 'agent-id)) "setup_failures")))) (("dynamic-auth" "create-token") (let ((opts (parse-options (append %client-options %base-options) (append %client-option-defaults %base-option-defaults) '()))) (let ((token (assoc-ref (send-create-dynamic-auth-token-request (assq-ref opts 'coordinator)) "token"))) (simple-format #t "~A\n" token)))) ((arguments ...) (simple-format (current-error-port) "locale is ~A\n" (check-locale!)) (let* ((opts (parse-options (append %service-options %base-options) (append %service-option-defaults %base-option-defaults) arguments)) (unknown-arguments (or (assq-ref opts 'arguments) '()))) (unless (null? unknown-arguments) (simple-format (current-error-port) "unknown arguments: ~A\n" unknown-arguments) (exit 1)) (let* ((hooks (filter-map (lambda (name) (and=> (assq-ref opts (symbol-append name '-hook)) (lambda (value) (cons name value)))) %known-hooks)) (hooks-with-defaults `(,@(filter cdr hooks) ,@(remove (match-lambda ((name . _) (assq-ref hooks name))) %default-hooks))) (build-coordinator (make-build-coordinator #:database-uri-string (assq-ref opts 'database) #:hooks hooks-with-defaults #:allocation-strategy (assq-ref opts 'allocation-strategy)))) (parameterize ((%show-error-details (assoc-ref opts 'show-error-details))) (run-coordinator-service build-coordinator #:update-datastore? (assoc-ref opts 'update-database) #:pid-file (assq-ref opts 'pid-file) #:agent-communication-uri (assq-ref opts 'agent-communication) #:client-communication-uri (assq-ref opts 'client-communication) #:parallel-hooks (assq-ref opts 'parallel-hooks)))))))