#!@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-19) (srfi srfi-37) (srfi srfi-43) (ice-9 match) (web uri) (fibers) (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)) (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 %builds-list-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 '("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))))) (define %builds-list-option-defaults `((tags . ()) (not-tags . ()) (systems . ()) (not-systems . ()) (processed . 'unset) (canceled . 'unset) (limit . 1000))) (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)))))) (define %build-cancel-option-defaults `((tags . ()) (not-tags . ()) (systems . ()) (not-systems . ()))) (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)))) (map (lambda (hook) (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))))) %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") (assoc-ref build-details "priority") (if (assoc-ref build-details "processed") "yes" "no") (if (assoc-ref build-details "canceled") "yes" "no")) (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))) (let loop ((after-id #f)) (let ((response (request-builds-list (assq-ref opts 'coordinator) #: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) #:after-id (or after-id (assq-ref opts 'after-id)) #:limit (assq-ref opts 'limit)))) (for-each (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"))) (vector->list (assoc-ref response "builds"))) (when (= (vector-length (assoc-ref response "builds")) (assq-ref opts 'limit)) (loop (assoc-ref (vector-ref (assoc-ref response "builds") (- (vector-length (assoc-ref response "builds")) 1)) "uuid"))))))) (("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 (find-matching-builds) (define limit 1000) (let loop ((after-id #f) (result '())) (let* ((response (request-builds-list (assq-ref opts 'coordinator) #: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 #:after-id after-id #:limit 1000)) (received-builds (vector-length (assoc-ref response "builds"))) (new-result (fold (lambda (build-details result) (cons (assoc-ref build-details "uuid") result)) result (vector->list (assoc-ref response "builds"))))) (display "." (current-error-port)) (force-output (current-error-port)) (if (< received-builds limit) new-result (loop (assoc-ref (vector-ref (assoc-ref response "builds") (- received-builds 1)) "uuid") new-result))))) (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 "canceling ~A builds" count) (current-error-port)) (lambda (report) (for-each (lambda (id) (send-cancel-build-request (assq-ref opts 'coordinator) id) (report)) matching-builds))))) ((build-id) (send-cancel-build-request (assq-ref opts 'coordinator) build-id))))) (("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" "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"))))) (("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* ((metrics-registry (make-metrics-registry #:namespace "guixbuildcoordinator")) (datastore (database-uri->datastore (assq-ref opts 'database) #:metrics-registry metrics-registry)) (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 #:datastore datastore #:hooks hooks-with-defaults #:metrics-registry metrics-registry #: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)))))))