Support listing and canceling builds by derivation system

3 files changed, 97 insertions, 7 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index cd164ec..921cfe9 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -309,6 +309,20 @@
                                         ((tag_key) tag_key))
                                       #f)))
                                query-parameters)
+                   #:systems
+                   (filter-map (match-lambda
+                                 ((key . value)
+                                  (if (eq? key 'system)
+                                      value
+                                      #f)))
+                               query-parameters)
+                   #:not-systems
+                   (filter-map (match-lambda
+                                 ((key . value)
+                                  (if (eq? key 'not-system)
+                                      value
+                                      #f)))
+                               query-parameters)
                    #:processed
                    (match (assq 'processed query-parameters)
                      ((_ . val)
@@ -503,6 +517,8 @@
                               #:key
                               (tags '())
                               (not-tags '())
+                              (systems '())
+                              (not-systems '())
                               (processed 'unset)
                               (canceled 'unset)
                               (after-id #f)
@@ -526,6 +542,16 @@
                         (key
                          (simple-format #f "not_tag=~A" key)))
                       not-tags))
+           ,@(if (null? systems)
+                 '()
+                 (map (lambda (system)
+                        (simple-format #f "system=~A" system))
+                      systems))
+           ,@(if (null? not-systems)
+                 '()
+                 (map (lambda (system)
+                        (simple-format #f "not-system=~A" system))
+                      not-systems))
            ,@(if (boolean? processed)
                  (if processed
                      '("processed=true")
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 71f67e6..107a799 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -1276,6 +1276,8 @@ WHERE uuid = :uuid"
   (define* (list-builds #:key
                         (tags '())
                         (not-tags '())
+                        (systems '())
+                        (not-systems '())
                         (processed 'unset)
                         (canceled 'unset)
                         (after-id #f)
@@ -1357,6 +1359,8 @@ SELECT id FROM tags WHERE key = :key"
              (let* ((where-needed?
                      (or (not (null? tag-expressions))
                          (not (null? not-tag-expressions))
+                         (not (null? systems))
+                         (not (null? not-systems))
                          (not (eq? processed 'unset))
                          (not (eq? canceled 'unset))))
                     (statement
@@ -1365,7 +1369,13 @@ SELECT id FROM tags WHERE key = :key"
                       (string-append
                        "
 SELECT uuid, derivation_name, priority, processed, canceled, created_at, end_time
-FROM builds
+FROM builds"
+                       (if (and (null? systems)
+                                (null? not-systems))
+                           ""
+                           "
+INNER JOIN derivations ON builds.derivation_name = derivations.name")
+                       "
 INNER JOIN (
   SELECT build_id, (',' || group_concat(tag_id) || ',') AS tag_string
   FROM build_tags
@@ -1384,6 +1394,22 @@ INNER JOIN (
                                 (if (null? all-tag-expressions)
                                     '()
                                     all-tag-expressions))
+                              (list
+                               (string-append
+                                "("
+                                (string-join
+                                 (map (lambda (system)
+                                        (simple-format
+                                         #f
+                                         "derivations.system = '~A'"
+                                         system))
+                                      systems)
+                                 " OR ")
+                                ")"))
+                              (map (lambda (system)
+                                     (simple-format #f "derivations.system != '~A'"
+                                                    system))
+                                   not-systems)
                               (cond
                                ((eq? processed #t) '("processed = 1"))
                                ((eq? processed #f) '("processed = 0"))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 537addc..78a9885 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -157,6 +157,20 @@
                                     (or (assq-ref result 'not-tags)
                                         '()))
                               (alist-delete 'not-tags result))))
+        (option '("system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'systems
+                              (cons arg
+                                    (or (assq-ref result 'systems)
+                                        '()))
+                              (alist-delete 'systems result))))
+        (option '("not-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'not-systems
+                              (cons arg
+                                    (or (assq-ref result 'not-systems)
+                                        '()))
+                              (alist-delete 'not-systems result))))
         (option '("processed") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'processed
@@ -181,6 +195,8 @@
 (define %builds-list-option-defaults
   `((tags         . ())
     (not-tags     . ())
+    (systems      . ())
+    (not-systems  . ())
     (processed    . 'unset)
     (canceled     . 'unset)
     (limit        . 1000)))
@@ -207,11 +223,27 @@
                                       ((key) key))
                                     (or (assq-ref result 'not-tags)
                                         '()))
-                              (alist-delete 'not-tags result))))))
+                              (alist-delete 'not-tags result))))
+        (option '("system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'systems
+                              (cons arg
+                                    (or (assq-ref result 'systems)
+                                        '()))
+                              (alist-delete 'systems result))))
+        (option '("not-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'not-systems
+                              (cons arg
+                                    (or (assq-ref result 'not-systems)
+                                        '()))
+                              (alist-delete 'not-systems result))))))
 
 (define %build-cancel-option-defaults
   `((tags         . ())
-    (not-tags     . ())))
+    (not-tags     . ())
+    (systems      . ())
+    (not-systems  . ())))
 
 (define %agent-tag-options
   (list (option '("tag") #t #f
@@ -427,6 +459,8 @@ canceled?:       ~A
                         (assq-ref opts 'coordinator)
                         #:tags (assq-ref opts 'tags)
                         #:not-tags (assq-ref opts 'not-tags)
+                        #:systems (assq-ref opts 'systems)
+                        #:not-systems (assq-ref opts 'not-systems)
                         #:processed (assq-ref opts 'processed)
                         #:canceled (assq-ref opts 'canceled)
                         #:after-id (or after-id (assq-ref opts 'after-id))
@@ -452,10 +486,12 @@ tags:
                                "false")
                            (assoc-ref build-details "priority")
                            (string-join
-                            (map (match-lambda
-                                   ((key . val)
-                                    (string-append "  " key ": " val)))
-                                 (assoc-ref build-details "tags"))
+                            (map (lambda (tag)
+                                   (let ((key (assoc-ref tag "key"))
+                                         (val (assoc-ref tag "value")))
+                                     (string-append "  " key ": " val)))
+                                 (vector->list
+                                  (assoc-ref build-details "tags")))
                             "\n")))
           (vector->list (assoc-ref response "builds")))
 
@@ -498,6 +534,8 @@ tags:
                            (assq-ref opts 'coordinator)
                            #:tags (assq-ref opts 'tags)
                            #:not-tags (assq-ref opts 'not-tags)
+                           #:systems (assq-ref opts 'systems)
+                           #:not-systems (assq-ref opts 'not-systems)
                            #:processed #f
                            #:canceled #f
                            #:after-id after-id