diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in | 5 | ||||
| -rw-r--r-- | scripts/guix-build-coordinator.in | 267 |
2 files changed, 134 insertions, 138 deletions
diff --git a/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in index 035fcfe..9cf0da2 100644 --- a/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in +++ b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in @@ -130,11 +130,6 @@ (string-append "--derivation-substitute-urls=" "https://" %guix-data-service-host) - ;; Currently submitting builds performs an allocation. Ideally this - ;; would just mark the plan as dirty to avoid repeatedly - ;; re-allocating builds. Until that point, pass this flag to skip - ;; allocating builds. - "--defer-allocation" ;; For the use case of providing substitutes, just build each ;; output once. "--ignore-if-build-for-derivation-exists" diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in index 52122bd..e5493de 100644 --- a/scripts/guix-build-coordinator.in +++ b/scripts/guix-build-coordinator.in @@ -37,7 +37,8 @@ (guix-build-coordinator datastore) (guix-build-coordinator coordinator) (guix-build-coordinator build-allocator) - (guix-build-coordinator agent-messaging http)) + (guix-build-coordinator agent-messaging http) + (guix-build-coordinator client-communication)) (define %base-options ;; Specifications of the command-line options @@ -71,6 +72,16 @@ ("" #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) @@ -92,18 +103,13 @@ (lambda (opt name arg result) (alist-cons 'derivation-substitute-urls (string-split arg #\space) - result))) - (option '("defer-allocation") #f #f - (lambda (opt name _ result) - (alist-cons 'defer-allocation #t result))))) - + 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) - (defer-allocation . #f))) + (ensure-all-related-derivation-outputs-have-builds . #f))) (define %service-options (list (option '("pid-file") #t #f @@ -116,6 +122,11 @@ (alist-cons 'agent-communication arg (alist-delete 'agent-communication result)))) + (option '("client-communication") #t #f + (lambda (opt name arg result) + (alist-cons 'client-communication + arg + (alist-delete 'client-communication result)))) (option '("allocation-strategy") #t #f (lambda (opt name arg result) (alist-cons @@ -151,6 +162,7 @@ (define %service-option-defaults ;; Alist of default option values `((agent-communication . "http://0.0.0.0:8745") + (client-communication . "http://127.0.0.1:8746") (allocation-strategy . ,basic-build-allocation-strategy) (build-success-hook . ,default-build-success-hook) (build-failure-hook . ,default-build-failure-hook) @@ -225,159 +237,139 @@ (let ((opts (parse-options %base-options %base-option-defaults rest))) - (let ((datastore (database-uri->datastore - (assq-ref opts 'database)))) - (define (display-build build-details) - (simple-format #t "derivation name: ~A + (define (display-build build-details) + (simple-format #t "derivation name: ~A priority: ~A processed?: ~A " - (assq-ref build-details 'derivation-name) - (assq-ref build-details 'priority) - (assq-ref build-details 'processed)) - - (let ((setup-failures - (datastore-list-setup-failures-for-build - datastore - (assq-ref build-details 'uuid)))) - (unless (null? setup-failures) - (display "\nsetup failures:\n") - (for-each - (lambda (setup-failure) - (simple-format #t " - agent: ~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 " - (assq-ref setup-failure 'agent-id) - (assq-ref setup-failure 'failure-reason)) - (when (string=? (assq-ref setup-failure 'failure-reason) - "missing_inputs") - (simple-format #t " missing inputs:\n") - (for-each (lambda (missing-input) - (simple-format #t - " - ~A\n" - missing-input) - (let ((builds-for-missing-input - (datastore-list-builds-for-output - datastore - missing-input))) - (for-each - (lambda (missing-input-build) - (simple-format - #t - " - ~A~A\n" - (assq-ref missing-input-build 'uuid) - (if (= 1 (assq-ref missing-input-build - 'processed)) - " (finished)" - ""))) - builds-for-missing-input))) - (datastore-list-setup-failure-missing-inputs - datastore - (assq-ref setup-failure 'id))) - (newline))) - setup-failures)))) + (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) + (simple-format #t + " - ~A\n" + 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)" + ""))) + (assoc-ref missing-input "builds"))) + (vector->list + (assoc-ref setup-failure "missing-inputs"))) + (newline))) + setup-failures)))) - (define (output? s) - (string-prefix? "/gnu/store/" s)) - - (match (assq-ref opts 'arguments) - (((? output? output)) - (for-each display-build - (datastore-list-builds-for-output datastore output))) - ((build-id) - (match (datastore-find-build datastore build-id) - (#f (display "no build found\n")) - (build-details - (display-build `((uuid . ,build-id) - ,@build-details))))))))) + (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" 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)))) - - (unless (file-exists? derivation-file) - (substitute-derivation derivation-file - #:substitute-urls - (assq-ref opts 'derivation-substitute-urls))) - - (let ((derivation (read-derivation-from-file derivation-file))) - - (when (assq-ref opts 'ignore-if-build-for-outputs-exists) - (for-each - (match-lambda - ((name . derivation-output) - (let ((builds-for-output - (datastore-list-builds-for-output - datastore - (derivation-output-path derivation-output)))) - - (unless (null? builds-for-output) - (simple-format - #t "there are already ~A builds for ~A, skipping\n" - (length builds-for-output) - (derivation-output-path derivation-output)) - (exit 0))))) - (derivation-outputs derivation))) - - (let ((uuid (submit-build - (make-build-coordinator - #:datastore datastore) - derivation - #:priority (assq-ref opts 'priority) - #:defer-allocation? (assq-ref opts 'defer-allocation) - #:ensure-all-related-derivation-outputs-have-builds? - (assq-ref - opts + (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)))) - (simple-format #t "build submitted as ~A\n" uuid)))))))) + (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"))))))))) (("agent" "new" rest ...) (let ((opts (parse-options (append %agent-options + %client-options %base-options) - %base-option-defaults + (append %client-option-defaults + %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 ((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 ((password (new-agent-password - (database-uri->datastore - (assq-ref opts 'database)) - #:agent id))) - (simple-format #t "new password: ~A\n" password)))) + (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" - (assq-ref agent 'uuid) - (or (assq-ref agent 'description) + (assoc-ref agent "uuid") + (or (assoc-ref agent "description") "(no description)"))) - (datastore-list-agents - (database-uri->datastore - (assq-ref opts 'database)))))) + (vector->list + (assoc-ref + (request-agents-list (assq-ref opts 'coordinator)) + "agents"))))) ((arguments ...) (let* ((opts (parse-options (append %service-options %base-options) @@ -447,6 +439,14 @@ processed?: ~A (assq-ref opts 'secret-key-base) build-coordinator chunked-request-channel))))))) + (client-communication-thunk + (let ((client-communication-uri + (string->uri (assq-ref opts 'client-communication)))) + (lambda () + (start-client-request-server (assq-ref opts 'secret-key-base) + (uri-host client-communication-uri) + (uri-port client-communication-uri) + build-coordinator))))) (start-hook-processing-thread build-coordinator) (trigger-build-allocation build-coordinator) @@ -457,6 +457,7 @@ processed?: ~A (run-fibers (lambda () (agent-communication-thunk) + (client-communication-thunk) (wait finished?)))) finished?))))))) |