diff options
| -rw-r--r-- | guix-build-coordinator/client-communication.scm | 21 | ||||
| -rw-r--r-- | guix-build-coordinator/datastore/sqlite.scm | 66 | ||||
| -rw-r--r-- | scripts/guix-build-coordinator.in | 28 |
3 files changed, 85 insertions, 30 deletions
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm index 9c13e76..aa5d9f0 100644 --- a/guix-build-coordinator/client-communication.scm +++ b/guix-build-coordinator/client-communication.scm @@ -50,6 +50,7 @@ request-builds-list request-output-details request-agent-details + request-agent-build-allocation-plan request-agents-list request-failed-builds-with-blocking-count-list send-create-agent-request @@ -253,12 +254,15 @@ (allocated_builds . ,(list->vector (datastore-list-agent-builds datastore - agent-id))) - (build_allocation_plan . ,(list->vector - (datastore-list-allocation-plan-builds - datastore - agent-id - 2048))))))) ; TODO Do something with this + agent-id))))))) + (('GET "agent" agent-id "build_allocation_plan") + (let ((agent-details (datastore-find-agent datastore agent-id))) + (render-json + `((build_allocation_plan + . ,(list->vector + (datastore-list-allocation-plan-builds + datastore + agent-id))))))) (('POST "agent" agent-id "passwords") (let ((password (new-agent-password datastore @@ -682,6 +686,11 @@ 'GET (string-append "/agent/" agent-id))) +(define (request-agent-build-allocation-plan coordinator-uri agent-id) + (send-request coordinator-uri + 'GET + (string-append "/agent/" agent-id "/build_allocation_plan"))) + (define (request-agents-list coordinator-uri) (send-request coordinator-uri 'GET diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm index 5bdbc6f..ff30c0b 100644 --- a/guix-build-coordinator/datastore/sqlite.scm +++ b/guix-build-coordinator/datastore/sqlite.scm @@ -2,6 +2,7 @@ #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-43) #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) @@ -3256,16 +3257,18 @@ WHERE agent_id = :agent_id" (define-method (datastore-list-allocation-plan-builds (datastore <sqlite-datastore>) - agent-id - limit) - (call-with-worker-thread - (slot-ref datastore 'worker-reader-thread-channel) - (lambda (db) - (let ((statement - (sqlite-prepare - db - ;; This needs to guard against the plan being out of date - " + . + rest) + (apply + (lambda* (agent-id #:key limit) + (call-with-worker-thread + (slot-ref datastore 'worker-reader-thread-channel) + (lambda (db) + (let ((statement + (sqlite-prepare + db + (string-append + " SELECT builds.uuid, derivations.name FROM builds INNER JOIN derivations @@ -3275,24 +3278,39 @@ INNER JOIN build_allocation_plan WHERE build_allocation_plan.agent_id = :agent_id AND builds.processed = 0 AND builds.id NOT IN (SELECT build_id FROM allocated_builds) -ORDER BY build_allocation_plan.ordering ASC +ORDER BY build_allocation_plan.ordering ASC" + (if limit + " LIMIT :limit" - #:cache? #t))) + "")) + #:cache? #t))) - (sqlite-bind-arguments - statement - #:agent_id agent-id - #:limit limit) + (apply sqlite-bind-arguments + statement + #:agent_id agent-id + (if limit + (list #:limit limit) + '())) - (let ((builds (sqlite-map - (match-lambda - (#(uuid derivation_name) - `((uuid . ,uuid) - (derivation-name . ,derivation_name)))) - statement))) - (sqlite-reset statement) + (let ((builds (sqlite-map + (match-lambda + (#(uuid derivation_name) + `((uuid . ,uuid) + (derivation-name . ,derivation_name) + (tags . ,(vector-map + (lambda (_ tag) + (match tag + ((key . value) + `((key . ,key) + (value . ,value))))) + (datastore-fetch-build-tags + datastore + uuid)))))) + statement))) + (sqlite-reset statement) - builds))))) + builds))))) + rest)) (define-method (datastore-list-agent-builds (datastore <sqlite-datastore>) diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in index 2483c7e..77dd245 100644 --- a/scripts/guix-build-coordinator.in +++ b/scripts/guix-build-coordinator.in @@ -850,6 +850,34 @@ tags: ('value . value)) (simple-format #t " - ~A: ~A\n" key value))) new-tags)))))) + (("agent" agent-id "build-allocation-plan" rest ...) + (let ((opts (parse-options (append %client-options + %base-options) + (append %client-option-defaults + %base-option-defaults) + rest))) + (let ((build-allocation-plan (assoc-ref + (request-agent-build-allocation-plan + (assq-ref opts 'coordinator) + agent-id) + "build_allocation_plan"))) + (vector-for-each + (lambda (index build) + (simple-format #t "~A: ~A\n" index (assoc-ref build "uuid")) + (simple-format #t " derivation name: ~A\n" + (assoc-ref build "derivation-name")) + (let ((tags (assoc-ref build "tags"))) + (unless (eq? 0 (vector-length tags)) + (simple-format #t " tags:\n") + (vector-for-each + (lambda (_ tag) + (let ((key (assoc-ref tag "key")) + (value (assoc-ref tag "value"))) + (simple-format #t " - ~A: ~A\n" + key value))) + tags))) + (newline)) + build-allocation-plan)))) (("agent" "list" rest ...) (let ((opts (parse-options %base-options (append %base-option-defaults |