#!@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) (use-modules (srfi srfi-1) (srfi srfi-37) (ice-9 match) (web uri) (fibers) (fibers conditions) (prometheus) ((guix ui) #:select (read/eval)) (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) (cons key value))) (or (assq-ref result 'tags) '())) (alist-delete 'tags 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 %service-options (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))) (option '("build-submitted-hook") #t #f (lambda (opt name arg result) (alist-cons 'build-submitted-hook (read/eval arg) (alist-delete 'build-submitted-hook result)))) (option '("build-started-hook") #t #f (lambda (opt name arg result) (alist-cons 'build-started-hook (read/eval arg) (alist-delete 'build-started-hook 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 `((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 %base-option-defaults rest))) (define (display-build build-details) (simple-format #t "derivation name: ~A priority: ~A processed?: ~A " (assoc-ref build-details "derivation-name") (assoc-ref build-details "priority") (if (assoc-ref build-details "processed") "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 (= 1 (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" "show-blocking" rest ...) (let ((opts (parse-options %base-options %base-option-defaults rest))) (let ((response (request-failed-builds-with-blocking-count-list (assq-ref opts 'coordinator)))) (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" 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 ((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)))) (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 "password" "new" rest ...) (let ((opts (parse-options %base-options %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" "list" rest ...) (let ((opts (parse-options %base-options %base-option-defaults rest))) (for-each (lambda (agent) (simple-format #t "~A: ~A\n" (assoc-ref agent "uuid") (or (assoc-ref agent "description") "(no description)"))) (vector->list (assoc-ref (request-agents-list (assq-ref opts 'coordinator)) "agents"))))) ((arguments ...) (let* ((opts (parse-options (append %service-options %base-options) (append %service-option-defaults %base-option-defaults) arguments)) (metrics-registry (make-metrics-registry #:namespace "guixbuildcoordinator")) (datastore (database-uri->datastore (assq-ref opts 'database) #:metrics-registry metrics-registry)) (hooks `((build-submitted . ,(assq-ref opts 'build-submitted-hook)) (build-started . ,(assq-ref opts 'build-started-hook)) (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)))) (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))))))