diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix-build-coordinator/client-communication.scm | 294 | ||||
| -rw-r--r-- | guix-build-coordinator/coordinator.scm | 92 | ||||
| -rw-r--r-- | scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in | 5 | ||||
| -rw-r--r-- | scripts/guix-build-coordinator.in | 267 |
5 files changed, 488 insertions, 171 deletions
diff --git a/Makefile.am b/Makefile.am index 747c597..59af3c8 100644 --- a/Makefile.am +++ b/Makefile.am @@ -9,6 +9,7 @@ SOURCES = \ guix-build-coordinator/agent-messaging/http.scm \ guix-build-coordinator/agent.scm \ guix-build-coordinator/build-allocator.scm \ + guix-build-coordinator/client-communication.scm \ guix-build-coordinator/config.scm \ guix-build-coordinator/coordinator.scm \ guix-build-coordinator/datastore.scm \ diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm new file mode 100644 index 0000000..b517f69 --- /dev/null +++ b/guix-build-coordinator/client-communication.scm @@ -0,0 +1,294 @@ +;;; Guix Build Coordinator +;;; +;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> +;;; +;;; 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 +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-build-coordinator client-communication) + #:use-module (srfi srfi-11) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (rnrs bytevectors) + #:use-module (json) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web request) + #:use-module (web response) + #:use-module (fibers web server) + #:use-module (system repl error-handling) + #:use-module (guix derivations) + #:use-module (guix-build-coordinator utils) + #:use-module (guix-build-coordinator datastore) + #:use-module (guix-build-coordinator coordinator) + #:export (start-client-request-server + + send-submit-build-request + request-build-details + request-agents-list + send-create-agent-request + send-create-agent-password-request)) + +(define (start-client-request-server secret-key-base + host + port + build-coordinator) + (call-with-error-handling + (lambda () + (run-server + (lambda (request body) + (display + (format #f "~4a ~a\n" + (request-method request) + (uri-path (request-uri request)))) + (apply values + (controller request + (cons (request-method request) + (split-and-decode-uri-path + (uri-path (request-uri request)))) + body + secret-key-base + build-coordinator))) + #:host host + #:port port)) + #:on-error 'backtrace)) + +(define (controller request + method-and-path-components + raw-body + secret-key-base + build-coordinator) + (define datastore + (build-coordinator-datastore build-coordinator)) + + (define body + (if raw-body + (json-string->scm (utf8->string raw-body)) + '())) + + (define (controller-thunk) + (match method-and-path-components + (('GET "build" uuid) + (match (datastore-find-build datastore uuid) + (#f + (render-json '((error . "no build found")) + #:code 404)) + (build-details + (let ((derivation-inputs + (map + (lambda (derivation-input-details) + (let ((builds (datastore-list-builds-for-output + datastore + (assq-ref derivation-input-details + 'output)))) + `(,@derivation-input-details + (builds . ,(list->vector builds))))) + (datastore-find-derivation-inputs + datastore + (assq-ref build-details 'derivation-name)))) + (setup-failures + (map + (lambda (setup-failure) + `(,@setup-failure + ,@(if (string=? (assq-ref setup-failure 'failure-reason) + "missing_inputs") + `((missing-inputs + . ,(map + (lambda (missing-input) + (let ((builds-for-missing-input + (datastore-list-builds-for-output + datastore + missing-input))) + `(,@missing-input + (builds . ,(list->vector + builds-for-missing-input))))) + (datastore-list-setup-failure-missing-inputs + datastore + (assq-ref setup-failure 'id))))) + '()))) + (datastore-list-setup-failures-for-build + datastore + (assq-ref build-details 'uuid))))) + (render-json + `(,@build-details + (derivation-inputs . ,(list->vector derivation-inputs)) + (setup-failures . ,(list->vector setup-failures)))))))) + (('GET "agents") + (render-json + `((agents . ,(list->vector (datastore-list-agents datastore)))))) + (('POST "agents") + (let ((uuid (new-agent + datastore + #:requested-uuid (assoc-ref body "requested-uuid") + #:description (assoc-ref body "description")))) + (render-json + `((agent-id . ,uuid))))) + (('POST "agent" agent-id "passwords") + (let ((password (new-agent-password + datastore + #:agent agent-id))) + (render-json + `((new-password . ,password))))) + (('POST "builds") + (let ((derivation-file (assoc-ref body "derivation"))) + (unless (file-exists? derivation-file) + (substitute-derivation derivation-file + #:substitute-urls + (vector->list + (assoc-ref body "substitute-urls")))) + + (let ((submit-build-result + (apply + submit-build + `(,build-coordinator + ,(read-derivation-from-file derivation-file) + ,@(let ((priority (assoc-ref body "priority"))) + (if priority + `(#:priority ,priority) + '())) + ,@(if (assoc-ref body "ignore-if-build-for-outputs-exists") + '(#:ignore-if-build-for-outputs-exists? #t) + '()) + ,@(if (assoc-ref + body "ensure-all-related-derivation-outputs-have-builds") + '(#:ensure-all-related-derivation-outputs-have-builds? #t) + '()))))) + (render-json submit-build-result)))) + (_ + (render-json + "not-found" + #:code 404)))) + + (call-with-error-handling + controller-thunk + #:on-error 'backtrace + #:post-error (lambda args + (match method-and-path-components + ((method path-components ...) + (simple-format + (current-error-port) + "error: when processing: /~A ~A\n" + method (string-join path-components "/")))) + (render-json + `((error . ,(simple-format #f "~A" args))) + #:code 500)))) + +(define* (render-json json #:key (extra-headers '()) + (code 200)) + (list (build-response + #:code code + #:headers (append extra-headers + '((content-type . (application/json)) + (vary . (accept))))) + (lambda (port) + (scm->json json port)))) + +(define* (send-request coordinator-uri + method + path + #:optional + request-body) + (let-values (((response body) + (http-request (string->uri + (string-append "http://localhost:8746" + path)) + #:method method + #:body (and=> request-body scm->json-string) + #:decode-body? #f))) + (if (>= (response-code response) 400) + (begin + (simple-format + (current-error-port) + "error: coordinator-http-request: ~A ~A: ~A\n" + method path (response-code response)) + (let ((body + (catch #t + (lambda () + (if (equal? '(application/json (charset . "utf-8")) + (response-content-type response)) + (json-string->scm (utf8->string body)) + (utf8->string body))) + (lambda (key . args) + (simple-format + (current-error-port) + "error decoding body ~A ~A\n" + key args) + #f)))) + (raise-exception + (make-exception-with-message + body)))) + (values + (json-string->scm (utf8->string body)) + response)))) + +(define (send-submit-build-request + coordinator-uri + derivation-file-name + substitute-urls + requested-uuid + priority + ignore-if-build-for-derivation-exists? + ignore-if-build-for-outputs-exists? + ensure-all-related-derivation-outputs-have-builds?) + (send-request coordinator-uri + 'POST + "/builds" + `((derivation . ,derivation-file-name) + (priority . ,priority) + ,@(if substitute-urls + `((substitute-urls . ,(list->vector substitute-urls))) + '()) + ,@(if ignore-if-build-for-derivation-exists? + '((ignore-if-build-for-derivation-exists . #t)) + '()) + ,@(if ignore-if-build-for-outputs-exists? + '((ignore-if-build-for-outputs-exists . #t)) + '()) + ,@(if ensure-all-related-derivation-outputs-have-builds? + '((ensure-all-related-derivation-outputs-have-builds . #t)) + '())))) + +(define (request-build-details coordinator-uri + uuid) + (send-request coordinator-uri + 'GET + (string-append "/build/" uuid))) + +(define (request-agents-list coordinator-uri) + (send-request coordinator-uri + 'GET + (string-append "/agents"))) + +(define* (send-create-agent-request coordinator-uri + #:key + requested-uuid + description) + (send-request coordinator-uri + 'POST + "/agents" + `(,@(if requested-uuid + `((requested-uuid . ,requested-uuid)) + '()) + ,@(if description + `((description . ,description)) + '())))) + +(define (send-create-agent-password-request coordinator-uri + agent-id) + (send-request coordinator-uri + 'POST + (string-append "/agent/" agent-id "/passwords"))) diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm index f0987a4..0eb8bd0 100644 --- a/guix-build-coordinator/coordinator.scm +++ b/guix-build-coordinator/coordinator.scm @@ -85,41 +85,67 @@ #:key requested-uuid (priority 0) + (ignore-if-build-for-derivation-exists? #f) + (ignore-if-build-for-outputs-exists? #f) (ensure-all-related-derivation-outputs-have-builds? #f)) - (let ((datastore (build-coordinator-datastore build-coordinator)) - (uuid (or requested-uuid (random-v4-uuid)))) - (datastore-store-derivation datastore derivation) - - (when ensure-all-related-derivation-outputs-have-builds? - (let ((derivations-lacking-builds - (datastore-list-related-derivations-with-no-build-for-outputs - datastore - (derivation-file-name derivation)))) - (for-each - (lambda (related-derivation) - (let ((related-uuid (random-v4-uuid))) - (simple-format #t "submtiting ~A for related ~A\n" - related-uuid - related-derivation) - (datastore-store-build datastore - related-derivation + (define datastore (build-coordinator-datastore build-coordinator)) + + (define (build-for-derivation-exists?) + (not + (null? (datastore-list-builds-for-derivation + datastore + (derivation-file-name derivation))))) + + (define (build-for-output-already-exists?) + (any + (match-lambda + ((name . derivation-output) + (let ((builds-for-output + (datastore-list-builds-for-output + datastore + (derivation-output-path derivation-output)))) + + (not (null? builds-for-output))))) + (derivation-outputs derivation))) + + (if (and ignore-if-build-for-derivation-exists? + (build-for-derivation-exists?)) + '((no-build-submitted . build-already-exists-for-this-derivation)) + (if (and ignore-if-build-for-outputs-exists? + (build-for-output-already-exists?)) + '((no-build-submitted . build-already-exists-for-a-output)) + + ;; Actually create a build + (let ((uuid (or requested-uuid (random-v4-uuid)))) + (datastore-store-derivation datastore derivation) + + (when ensure-all-related-derivation-outputs-have-builds? + (let ((derivations-lacking-builds + (datastore-list-related-derivations-with-no-build-for-outputs + datastore + (derivation-file-name derivation)))) + (for-each + (lambda (related-derivation) + (let ((related-uuid (random-v4-uuid))) + (simple-format #t "submtiting ~A for related ~A\n" related-uuid - ;; Let the scheduler take care of - ;; the prioritisation - 0))) - derivations-lacking-builds))) - - (datastore-store-build datastore - (derivation-file-name derivation) - uuid - priority) - - (unless defer-allocation? - ;; This can be removed once allocation in the main coordinator process can - ;; be triggered - (allocate-builds build-coordinator)) - - uuid)) + related-derivation) + (datastore-store-build datastore + related-derivation + related-uuid + ;; Let the scheduler take care of + ;; the prioritisation + 0))) + derivations-lacking-builds))) + + (datastore-store-build datastore + (derivation-file-name derivation) + uuid + priority) + + (trigger-build-allocation build-coordinator) + + `((build-submitted . ,uuid)))))) (define* (new-agent datastore #:key 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?))))))) |