Fix up a load of the tag related code

Turns out vector-fold and vector-map don't work like I'd expected them to,
like fold and map for vectors.

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