From 89c2823f1a332da9e9ea3a4f84ef27cce7e22a3a Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 19 Jun 2020 16:55:01 +0100 Subject: Handle the system more explicitly when fetching builds Also support fetching builds for specific systems from the Guix Data Service. --- guix-build-coordinator/agent-messaging/http.scm | 9 ++- guix-build-coordinator/agent.scm | 2 + guix-build-coordinator/coordinator.scm | 3 +- guix-build-coordinator/datastore/sqlite.scm | 14 +++- scripts/guix-build-coordinator-agent.in | 15 +++- ...rdinator-queue-builds-from-guix-data-service.in | 94 +++++++++++++++++----- 6 files changed, 106 insertions(+), 31 deletions(-) diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm index e7c17aa..f7459ad 100644 --- a/guix-build-coordinator/agent-messaging/http.scm +++ b/guix-build-coordinator/agent-messaging/http.scm @@ -292,7 +292,10 @@ port. Also, the port used can be changed by passing the --port option.\n" (if (authenticated? uuid request) (let* ((json-body (json-string->scm (utf8->string body))) (count (assoc-ref json-body "count")) - (builds (fetch-builds build-coordinator uuid count))) + (systems (assoc-ref json-body "systems")) + (builds (fetch-builds build-coordinator uuid + (vector->list systems) + count))) (render-json `((builds . ,(list->vector builds))))) (render-json @@ -696,11 +699,13 @@ port. Also, the port used can be changed by passing the --port option.\n" #:succeed-on-access-denied-retry? #t)) (define* (fetch-builds-for-agent coordinator-uri agent-uuid password + systems #:key (count 1)) (vector->list (assoc-ref (coordinator-http-request coordinator-uri agent-uuid password (string-append "/agent/" agent-uuid "/fetch-builds") - #:body `((count . ,count)) + #:body `((count . ,count) + (systems . ,(list->vector systems))) #:method 'POST) "builds"))) diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm index 06518ed..a5a3f7a 100644 --- a/guix-build-coordinator/agent.scm +++ b/guix-build-coordinator/agent.scm @@ -36,12 +36,14 @@ #:export (run-agent)) (define (run-agent uuid coordinator-uri password + systems max-parallel-builds derivation-substitute-urls non-derivation-substitute-urls) (define (fetch-new-jobs count) (let ((received-builds (fetch-builds-for-agent coordinator-uri uuid password + systems #:count count))) (simple-format #t "requested ~A builds, received ~A\n" count (length received-builds)) diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm index 83f1e68..f76c783 100644 --- a/guix-build-coordinator/coordinator.scm +++ b/guix-build-coordinator/coordinator.scm @@ -321,7 +321,7 @@ #t) -(define (fetch-builds build-coordinator agent count) +(define (fetch-builds build-coordinator agent systems count) (call-with-duration-metric (build-coordinator-metrics-registry build-coordinator) "guixbuildcoordinator_coordinator_fetch_builds_duration_seconds" @@ -329,6 +329,7 @@ (datastore-allocate-builds-to-agent (build-coordinator-datastore build-coordinator) agent + systems count)))) (define (agent-details datastore agent-id) diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm index 2b39c51..0497bab 100644 --- a/guix-build-coordinator/datastore/sqlite.scm +++ b/guix-build-coordinator/datastore/sqlite.scm @@ -1286,20 +1286,24 @@ SELECT agent_id, COUNT(*) FROM allocated_builds GROUP BY agent_id"))) (define-method (datastore-allocate-builds-to-agent (datastore ) agent-id + systems count) (define (fetch-build db) (let ((statement (sqlite-prepare db ;; This needs to guard against the plan being out of date - " + (simple-format #f " SELECT builds.uuid, builds.derivation_name FROM builds INNER JOIN build_allocation_plan ON builds.uuid = build_allocation_plan.build_id +INNER JOIN derivations + ON builds.derivation_name = derivations.name WHERE build_allocation_plan.agent_id = :agent_id AND builds.processed = 0 AND builds.uuid NOT IN (SELECT build_id FROM allocated_builds) + AND derivations.system IN (~A) AND NOT EXISTS ( SELECT 1 FROM derivation_outputs AS build_derivation_outputs @@ -1315,8 +1319,12 @@ WHERE build_allocation_plan.agent_id = :agent_id allocated_builds_derivation_outputs.output ) ORDER BY build_allocation_plan.ordering ASC -LIMIT 1"))) - +LIMIT 1" + (string-join + (map (lambda (system) + (string-append "'" system "'")) + systems) + ","))))) (sqlite-bind-arguments statement #:agent_id agent-id) diff --git a/scripts/guix-build-coordinator-agent.in b/scripts/guix-build-coordinator-agent.in index 5c8549e..730d90f 100644 --- a/scripts/guix-build-coordinator-agent.in +++ b/scripts/guix-build-coordinator-agent.in @@ -24,6 +24,7 @@ (use-modules (srfi srfi-1) (srfi srfi-37) + ((guix config) #:prefix guix-config:) (guix-build-coordinator agent)) (define %options @@ -62,12 +63,19 @@ (lambda (opt name arg result) (alist-cons 'non-derivation-substitute-urls (string-split arg #\space) - result))))) + result))) + (option '("system") #t #f + (lambda (opt name arg result) + (alist-cons 'systems + (cons arg + (or (assq-ref result 'system-and-target) + '())) + (alist-delete 'systems result)))))) (define %option-defaults - ;; Alist of default option values `((coordinator . "http://localhost:8745") - (max-parallel-builds . 1))) + (max-parallel-builds . 1) + (systems . (,guix-config:%system)))) (define (parse-options options defaults args) (args-fold @@ -87,6 +95,7 @@ (run-agent (assq-ref opts 'uuid) (assq-ref opts 'coordinator) (assq-ref opts 'password) + (assq-ref opts 'systems) (assq-ref opts 'max-parallel-builds) (or (assq-ref opts 'derivation-substitute-urls) (assq-ref opts 'substitute-urls)) 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 0690244..664c442 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 @@ -24,6 +24,7 @@ (use-modules (srfi srfi-1) (srfi srfi-11) + (srfi srfi-37) (ice-9 match) (ice-9 textual-ports) (rnrs bytevectors) @@ -155,30 +156,79 @@ #:times 6 #:delay 30)) -(define (submit-builds-for-revision commit) +(define (submit-builds-for-revision commit systems-and-targets) (simple-format #t "looking at revision ~A\n" commit) - (for-each (lambda (derivation) - (submit-build derivation #:priority 1000)) - (channel-instance-derivations-for-commit commit "x86_64-linux")) - - (let ((unprocessed-package-derivations - (filter (lambda (derivation) - (not (hash-ref processed-derivations-hash derivation))) - (package-derivations-for-commit commit - #:system "x86_64-linux" - #:target "none")))) - - (for-each submit-build unprocessed-package-derivations) - (record-derivations-as-processed unprocessed-package-derivations))) + (for-each + (match-lambda + ((system . target) + (for-each (lambda (derivation) + (submit-build derivation #:priority 1000)) + (channel-instance-derivations-for-commit commit system)) + + (let ((unprocessed-package-derivations + (filter (lambda (derivation) + (not (hash-ref processed-derivations-hash derivation))) + (package-derivations-for-commit commit + #:system system + #:target target)))) + + (for-each submit-build unprocessed-package-derivations) + (record-derivations-as-processed unprocessed-package-derivations)))) + systems-and-targets)) + +(define %options + (list (option '("system") #t #f + (lambda (opt name arg result) + (peek "ARG" arg) + (alist-cons 'systems-and-targets + `((,arg . "none") + ,@(or (assq-ref result 'systems-and-targets) '())) + (alist-delete 'systems-and-targets result)))) + (option '("system-and-target") #t #f + (lambda (opt name arg result) + (alist-cons 'systems-and-targets + (match (string-split arg #\=) + ((system target) + `((,system . ,target) + ,@(or (assq-ref result 'systems-and-targets) '())))) + (alist-delete 'systems-and-targets result)))))) + +(define %option-defaults + '()) + +(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)) (define (main) - (while #t - (for-each (lambda (commit) - (submit-builds-for-revision commit) - (record-revision-as-processed commit)) - (unseen-revisions)) - - (simple-format #t "waiting before checking for new revisions...\n") - (sleep 60))) + (let* ((opts (parse-options %options + %option-defaults + (cdr (program-arguments)))) + (systems-and-targets + (assq-ref opts 'systems-and-targets))) + + (unless (peek systems-and-targets) + (simple-format (current-error-port) + "error: you must specify at least one system to fetch builds for\n") + (exit 1)) + + (while #t + (for-each (lambda (commit) + (submit-builds-for-revision commit systems-and-targets) + (record-revision-as-processed commit)) + (unseen-revisions)) + + (simple-format #t "waiting before checking for new revisions...\n") + (sleep 60)))) (main) -- cgit v1.2.3