aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2020-05-17 21:00:54 +0100
committerChristopher Baines <mail@cbaines.net>2020-05-17 21:00:54 +0100
commita6eabc572445869e0494a2b9962407352bb86c1d (patch)
tree1b0da65c226d5ea2dafa99b428c2a8037af1fd08
parentaad8a02d33b3d35f946dd0e03289306b9d9af703 (diff)
downloadbuild-coordinator-a6eabc572445869e0494a2b9962407352bb86c1d.tar
build-coordinator-a6eabc572445869e0494a2b9962407352bb86c1d.tar.gz
Convert the client actions to happen over HTTP
There were a few issues with the previous approach, I was concerned about trying to write to the SQLite database from two processes, it's already segfaulting occasionally when accessing it from just one. Additionally, the client actions were already doing things that should happen in the coordinator process, like allocating builds. I'm trying to not turn this in to a web app, but not doing very well. Although having this information and these actions available over the network does make it possible to build a web app frontend, which I've had in mind.
-rw-r--r--Makefile.am1
-rw-r--r--guix-build-coordinator/client-communication.scm294
-rw-r--r--guix-build-coordinator/coordinator.scm92
-rw-r--r--scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in5
-rw-r--r--scripts/guix-build-coordinator.in267
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?)))))))