aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--guix-build-coordinator/build-allocator.scm4
-rw-r--r--guix-build-coordinator/client-communication.scm46
-rw-r--r--guix-build-coordinator/datastore/sqlite.scm21
-rw-r--r--scripts/guix-build-coordinator.in50
4 files changed, 83 insertions, 38 deletions
diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index aaf9dd6..917a567 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -158,7 +158,7 @@
((_ . build-value)
(string=? agent-value build-value)))
(vector-fold
- (lambda (tag result)
+ (lambda (_ result tag)
(if (string=? (car tag)
agent-key)
(cons tag result)
@@ -541,7 +541,7 @@
((_ . build-value)
(string=? agent-value build-value)))
(vector-fold
- (lambda (tag result)
+ (lambda (_ result tag)
(if (string=? (car tag)
agent-key)
(cons tag result)
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 98e73e6..16fa529 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -22,6 +22,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-43)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
@@ -176,7 +177,13 @@
(lambda (time)
(strftime "%F %T" time)))
'null))
- (tags . ,tags)
+ (tags . ,(vector-map
+ (lambda (_ tag)
+ (match tag
+ ((key . value)
+ `((key . ,key)
+ (value . ,value)))))
+ tags))
(derivation-inputs . ,(list->vector derivation-inputs))
(setup-failures . ,(list->vector setup-failures))))))))
(('POST "build" uuid "cancel")
@@ -210,9 +217,15 @@
(render-json
`((id . ,agent-id)
,@agent-details
- (tags . ,(datastore-fetch-agent-tags
- datastore
- agent-id))
+ (tags . ,(vector-map
+ (lambda (_ tag)
+ (match tag
+ ((key . value)
+ `((key . ,key)
+ (value . ,value)))))
+ (datastore-fetch-agent-tags
+ datastore
+ agent-id)))
(allocated_builds . ,(list->vector
(datastore-list-agent-builds
datastore
@@ -232,9 +245,14 @@
(let ((agent-details (datastore-find-agent datastore agent-id)))
(if agent-details
(begin
- (datastore-replace-agent-tags datastore
- agent-id
- (assoc-ref body "tags"))
+ (datastore-replace-agent-tags
+ datastore
+ agent-id
+ (vector-map
+ (lambda (_ tag)
+ `((key . ,(assoc-ref tag "key"))
+ (value . ,(assoc-ref tag "value"))))
+ (assoc-ref body "tags")))
(render-json
`((result . success))))
(render-json
@@ -452,17 +470,11 @@
'())
,@(if (null? tags)
'()
- `((tags . ,(list->vector
- (map (match-lambda
- ((key . value)
- `((key . ,key)
- (value . ,value))))
- tags)))))
+ `((tags . ,(list->vector tags))))
,@(if defer-until
`((defer-until . ,(date->string defer-until "~1 ~3")))
'()))))
-
(define (send-cancel-build-request
coordinator-uri
build-id)
@@ -488,7 +500,8 @@
`(,@(if (null? tags)
'()
(map (match-lambda
- ((key . value)
+ ((('key . key)
+ ('value . value))
(simple-format #f "tag=~A:~A" key value))
(key
(simple-format #f "tag=~A" key)))
@@ -496,7 +509,8 @@
,@(if (null? not-tags)
'()
(map (match-lambda
- ((key . value)
+ ((('key . key)
+ ('value . value))
(simple-format #f "not_tag=~A:~A" key value))
(key
(simple-format #f "not_tag=~A" key)))
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 6af0b46..a66614a 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -532,19 +532,26 @@ INSERT INTO agent_tags (agent_id, tag_id) VALUES (:agent_id, :tag_id)"
result))
+ (define (insert-tag key value)
+ (sqlite-bind-arguments agent-tags-statement
+ #:agent_id agent-id
+ #:tag_id (tag->id key value))
+ (sqlite-step agent-tags-statement)
+ (sqlite-reset agent-tags-statement))
+
(sqlite-bind-arguments delete-agent-tags-statement
#:agent_id agent-id)
(sqlite-step delete-agent-tags-statement)
(sqlite-reset delete-agent-tags-statement)
(for-each
(match-lambda
- ((key . value)
- (sqlite-bind-arguments agent-tags-statement
- #:agent_id agent-id
- #:tag_id (tag->id key value))
- (sqlite-step agent-tags-statement)
- (sqlite-reset agent-tags-statement)))
- tags))))
+ ((('key . key)
+ ('value . value))
+ (insert-tag key value))
+ ((key . value) (insert-tag key value)))
+ (if (vector? tags)
+ (vector->list tags)
+ tags)))))
#t)
(define-method (datastore-store-derivation
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index c33d37a..537addc 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -28,6 +28,7 @@
(use-modules (srfi srfi-1)
(srfi srfi-19)
(srfi srfi-37)
+ (srfi srfi-43)
(ice-9 match)
(web uri)
(fibers)
@@ -114,7 +115,9 @@
(lambda (opt name arg result)
(alist-cons 'tags
(cons (match (string-split arg #\=)
- ((key value) (cons key value)))
+ ((key value)
+ `((key . ,key)
+ (value . ,value))))
(or (assq-ref result 'tags)
'()))
(alist-delete 'tags result))))
@@ -136,7 +139,9 @@
(lambda (opt name arg result)
(alist-cons 'tags
(cons (match (string-split arg #\=)
- ((key value) (cons key value))
+ ((key value)
+ `((key . ,key)
+ (value . ,value)))
((key) key))
(or (assq-ref result 'tags)
'()))
@@ -145,7 +150,9 @@
(lambda (opt name arg result)
(alist-cons 'not-tags
(cons (match (string-split arg #\=)
- ((key value) (cons key value))
+ ((key value)
+ `((key . ,key)
+ (value . ,value)))
((key) key))
(or (assq-ref result 'not-tags)
'()))
@@ -183,7 +190,9 @@
(lambda (opt name arg result)
(alist-cons 'tags
(cons (match (string-split arg #\=)
- ((key value) (cons key value))
+ ((key value)
+ `((key . ,key)
+ (value . ,value)))
((key) key))
(or (assq-ref result 'tags)
'()))
@@ -192,7 +201,9 @@
(lambda (opt name arg result)
(alist-cons 'not-tags
(cons (match (string-split arg #\=)
- ((key value) (cons key value))
+ ((key value)
+ `((key . ,key)
+ (value . ,value)))
((key) key))
(or (assq-ref result 'not-tags)
'()))
@@ -207,7 +218,9 @@
(lambda (opt name arg result)
(alist-cons 'tags
(cons (match (string-split arg #\=)
- ((key value) (cons key value)))
+ ((key value)
+ `((key . ,key)
+ (value . ,value))))
(or (assq-ref result 'tags)
'()))
(alist-delete 'tags result))))
@@ -215,7 +228,9 @@
(lambda (opt name arg result)
(alist-cons 'remove-tags
(cons (match (string-split arg #\=)
- ((key value) (cons key value))
+ ((key value)
+ `((key . ,key)
+ (value . ,value)))
((key) key))
(or (assq-ref result 'remove-tags)
'()))
@@ -613,12 +628,20 @@ tags:
(let ((agent-details (request-agent-details
(assq-ref opts 'coordinator)
agent-id)))
- (let* ((initial-tags (assoc-ref agent-details "tags"))
+ (let* ((initial-tags (vector-fold
+ (lambda (_ result tag)
+ (cons `((key . ,(assoc-ref tag "key"))
+ (value . ,(assoc-ref tag "value")))
+ result))
+ '()
+ (assoc-ref agent-details "tags")))
(new-tags (remove
(match-lambda
- ((key . val)
+ ((('key . key)
+ ('value . val))
(any (match-lambda
- ((k . v)
+ ((('key . k)
+ ('value . v))
(and (string=? key k)
(string=? val v)))
(k
@@ -629,11 +652,12 @@ tags:
(let ((response (send-replace-agent-tags-request
(assq-ref opts 'coordinator)
agent-id
- new-tags)))
+ (list->vector new-tags))))
(simple-format #t "changed tags to:\n")
(for-each (match-lambda
- ((k . v)
- (simple-format #t " - ~A: ~A\n" k v)))
+ ((('key . key)
+ ('value . value))
+ (simple-format #t " - ~A: ~A\n" key value)))
new-tags))))))
(("agent" "list" rest ...)
(let ((opts (parse-options %base-options
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-21 19:21:14 +0000