Support updating build priorities through the command line

1 files changed, 160 insertions, 70 deletions

diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 937ee4b..2483c7e 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -141,75 +141,66 @@
     (ensure-all-related-derivation-outputs-have-builds . #f)
     (tags                                              . ())))
 
-(define %builds-list-options
-  (list (option '("tag") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'tags
-                              (cons (match (string-split arg #\=)
-                                      ((key value)
-                                       `((key   . ,key)
-                                         (value . ,value)))
-                                      ((key) key))
-                                    (or (assq-ref result 'tags)
-                                        '()))
-                              (alist-delete 'tags result))))
-        (option '("not-tag") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'not-tags
-                              (cons (match (string-split arg #\=)
-                                      ((key value)
-                                       `((key   . ,key)
-                                         (value . ,value)))
-                                      ((key) key))
-                                    (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
-                              (string=? arg "true")
-                              result)))
-        (option '("canceled") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'canceled
-                              (string=? arg "true")
-                              result)))
-        (option '("priority-gt") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'priority->
-                              (string->number arg)
-                              result)))
-        (option '("priority-lt") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'priority-<
-                              (string->number arg)
-                              result)))
-        (option '("after-id") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'after-id
-                              arg
-                              result)))
-        (option '("limit") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'limit
-                              (string->number arg)
-                              result)))))
-
-(define %builds-list-option-defaults
+(define %common-build-filtering-options
+  (list
+   (option '("tag") #t #f
+           (lambda (opt name arg result)
+             (alist-cons 'tags
+                         (cons (match (string-split arg #\=)
+                                 ((key value)
+                                  `((key   . ,key)
+                                    (value . ,value)))
+                                 ((key) key))
+                               (or (assq-ref result 'tags)
+                                   '()))
+                         (alist-delete 'tags result))))
+   (option '("not-tag") #t #f
+           (lambda (opt name arg result)
+             (alist-cons 'not-tags
+                         (cons (match (string-split arg #\=)
+                                 ((key value)
+                                  `((key   . ,key)
+                                    (value . ,value)))
+                                 ((key) key))
+                               (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
+                         (string=? arg "true")
+                         result)))
+   (option '("canceled") #t #f
+           (lambda (opt name arg result)
+             (alist-cons 'canceled
+                         (string=? arg "true")
+                         result)))
+   (option '("priority-gt") #t #f
+           (lambda (opt name arg result)
+             (alist-cons 'priority->
+                         (string->number arg)
+                         result)))
+   (option '("priority-lt") #t #f
+           (lambda (opt name arg result)
+             (alist-cons 'priority-<
+                         (string->number arg)
+                         result)))))
+
+(define %common-build-filtering-option-defaults
   `((tags         . ())
     (not-tags     . ())
     (systems      . ())
@@ -217,7 +208,23 @@
     (processed    . 'unset)
     (canceled     . 'unset)
     (priority->   . 'unset)
-    (priority-<   . 'unset)
+    (priority-<   . 'unset)))
+
+(define %builds-list-options
+  (cons* (option '("after-id") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'after-id
+                               arg
+                               result)))
+         (option '("limit") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'limit
+                               (string->number arg)
+                               result)))
+         %common-build-filtering-options))
+
+(define %builds-list-option-defaults
+  `(,@%common-build-filtering-option-defaults
     (limit        . 1000)))
 
 (define %build-cancel-options
@@ -264,6 +271,17 @@
     (systems      . ())
     (not-systems  . ())))
 
+(define %build-update-priority-options
+  (cons* (option '("new-priority") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'new-priority
+                               (string->number arg)
+                               (alist-delete 'new-priority result))))
+         %common-build-filtering-options))
+
+(define %build-update-priority-option-defaults
+  %common-build-filtering-option-defaults)
+
 (define %build-show-blocking-options
   (list (option '("system") #t #f
                 (lambda (opt name arg result)
@@ -618,6 +636,78 @@ tags:
        ((build-id)
         (send-cancel-build-request (assq-ref opts 'coordinator)
                                    build-id)))))
+  (("build" "update-priority" rest ...)
+   (let ((opts (parse-options (append %client-options
+                                      %base-options
+                                      %build-update-priority-options)
+                              (append %client-option-defaults
+                                      %base-option-defaults
+                                      %build-update-priority-option-defaults)
+                              rest)))
+     (define (find-matching-builds)
+       (define limit 1000)
+
+       (let loop ((after-id #f)
+                  (result '()))
+         (let* ((response (request-builds-list
+                           (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
+                           #:priority-> (assq-ref opts 'priority->)
+                           #:priority-< (assq-ref opts 'priority-<)
+                           #:after-id after-id
+                           #:limit 1000))
+                (received-builds
+                 (vector-length (assoc-ref response "builds")))
+                (new-result
+                 (fold
+                  (lambda (build-details result)
+                    (cons (assoc-ref build-details "uuid")
+                          result))
+                  result
+                  (vector->list (assoc-ref response "builds")))))
+           (display "." (current-error-port))
+           (force-output (current-error-port))
+           (if (< received-builds limit)
+               new-result
+               (loop (assoc-ref (vector-ref (assoc-ref response "builds")
+                                            (- received-builds 1))
+                                "uuid")
+                     new-result)))))
+
+     (match (assq-ref opts 'arguments)
+       (#f
+        (simple-format (current-error-port)
+                       "requesting matching builds")
+        (force-output (current-error-port))
+        (let* ((matching-builds (find-matching-builds))
+               (count (length matching-builds)))
+          (simple-format (current-error-port)
+                         "\nfound ~A builds matching criteria\n"
+                         count)
+
+          (call-with-progress-reporter (progress-reporter/bar
+                                        count
+                                        (simple-format
+                                         #f
+                                         "updating priorities for ~A builds" count)
+                                        (current-error-port))
+            (lambda (report)
+              (for-each (lambda (id)
+                          (send-update-build-priority-request
+                           (assq-ref opts 'coordinator)
+                           id
+                           (assq-ref opts 'new-priority))
+                          (report))
+                        matching-builds)))))
+       ((build-id)
+        (send-update-build-priority-request (assq-ref opts 'coordinator)
+                                            build-id
+                                            (assq-ref opts 'new-priority))))))
   (("build" rest ...)
    (let ((opts (parse-options (append %build-options
                                       %base-options)