Add more options when updating build priorities

Computing new derived priorities is slow, so these options allow skipping that
if you know what you're doing. For example, if you're updating a batch of
related builds and you want them all to have the same priorities and derived
priorities, you can now do that much quicker.

4 files changed, 71 insertions, 24 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 8b2b9a2..4ce0bbf 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -192,13 +192,22 @@
                                        "")
                                       "true")))))))
       (('POST "build" uuid "update-priority")
-       (update-build-priority
-        build-coordinator
-        uuid
-        (assoc-ref body "new_priority"))
+       (let ((query-parameters (request-query-parameters request)))
+         (update-build-priority
+          build-coordinator
+          uuid
+          (assoc-ref body "new_priority")
+          #:skip-updating-derived-priorities?
+          (string=? (or
+                     (assq-ref query-parameters
+                               'skip-updating-derived-priorities)
+                     "")
+                    "true")
+          #:override-derived-priority
+          (assoc-ref body "override_derived_priority"))
 
-       (render-json
-        `((result . "build-priority-updated"))))
+         (render-json
+          `((result . "build-priority-updated")))))
       (('GET "builds" "blocking")
        (let ((query-parameters (request-query-parameters request)))
          (render-json
@@ -771,14 +780,23 @@
                                    "&skip-updating-derived-priorities=true"
                                    ""))))
 
-(define (send-update-build-priority-request
-         coordinator-uri
-         build-id
-         new-priority)
+(define* (send-update-build-priority-request
+          coordinator-uri
+          build-id
+          new-priority
+          #:key skip-updating-derived-priorities?
+          override-derived-priority)
   (send-request coordinator-uri
                 'POST
-                (string-append "/build/" build-id "/update-priority")
-                `((new_priority . ,new-priority))))
+                (string-append "/build/" build-id "/update-priority"
+                               (if skip-updating-derived-priorities?
+                                   "?skip-updating-derived-priorities=true"
+                                   ""))
+                `((new_priority . ,new-priority)
+                  ,@(if override-derived-priority
+                        `((override_derived_priority
+                           . ,override-derived-priority))
+                        '()))))
 
 (define (request-build-details coordinator-uri
                                uuid)
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 906f6ee..916ed92 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -850,7 +850,9 @@
             (perform-operation)))
       (perform-operation)))
 
-(define (update-build-priority build-coordinator uuid new-priority)
+(define* (update-build-priority build-coordinator uuid new-priority
+                                #:key skip-updating-derived-priorities?
+                                override-derived-priority)
   (define datastore (build-coordinator-datastore build-coordinator))
 
   (datastore-call-with-transaction
@@ -865,9 +867,13 @@
          (raise-exception
           (make-client-error 'build-already-processed))))
 
-     (datastore-update-build-priority datastore
-                                      uuid
-                                      new-priority)))
+     (datastore-update-build-priority
+      datastore
+      uuid
+      new-priority
+      #:skip-updating-derived-priorities?
+      skip-updating-derived-priorities?
+      #:override-derived-priority override-derived-priority)))
 
   (trigger-build-allocation build-coordinator)
 
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 888775e..f10af88 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -1638,7 +1638,8 @@ WHERE build_id = :build_id"
 
   (apply
    (lambda* (uuid new-priority
-                  #:key skip-updating-other-build-derived-priorities)
+                  #:key skip-updating-derived-priorities?
+                  override-derived-priority)
      (let ((build-id
             old-priority
             (call-with-worker-thread
@@ -1664,8 +1665,9 @@ WHERE build_id = :build_id"
                     db
                     build-id))
                   (new-derived-priority
-                   (max new-priority
-                        (get-derived-priority db build-id))))
+                   (or override-derived-priority
+                       (max new-priority
+                            (get-derived-priority db build-id)))))
 
               (unless (eq? old-derived-priority
                            new-derived-priority)
@@ -1674,7 +1676,7 @@ WHERE build_id = :build_id"
                                                   new-derived-priority))
 
               (unless (or all-inputs-built?
-                          skip-updating-other-build-derived-priorities)
+                          skip-updating-derived-priorities?)
                 (when (> new-derived-priority
                          old-derived-priority)
                   (update-unprocessed-builds-with-higher-derived-priorities
@@ -1687,8 +1689,8 @@ WHERE build_id = :build_id"
          ;; transaction, but since there could be lots of builds to update the
          ;; priority of, and a new derived priority has to be calculated for
          ;; each one, it's better to handle it afterwards.
-         (when (< new-priority
-                  old-priority)
+         (when (and (not skip-updating-derived-priorities?)
+                    (< new-priority old-priority))
            (datastore-update-unprocessed-builds-with-lower-derived-priorities
             datastore
             uuid
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 4ceace0..23a356f 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -40,6 +40,7 @@
              (srfi srfi-71)
              (ice-9 match)
              (ice-9 streams)
+             (ice-9 exceptions)
              (ice-9 suspendable-ports)
              (web uri)
              (fibers)
@@ -313,6 +314,16 @@
                    (alist-cons 'new-priority
                                (string->number arg)
                                (alist-delete 'new-priority result))))
+         (option '("override-derived-priority") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'override-derived-priority
+                               (string->number arg)
+                               (alist-delete 'override-derived-priority result))))
+         (option '("skip-updating-derived-priorities") #f #f
+                 (lambda (opt name _ result)
+                   (alist-cons 'skip-updating-derived-priorities
+                               #t
+                               result)))
          %common-build-filtering-options))
 
 (define %build-update-priority-option-defaults
@@ -725,10 +736,20 @@ tags:
                              (send-update-build-priority-request
                               (assq-ref opts 'coordinator)
                               id
-                              (assq-ref opts 'new-priority))
+                              (assq-ref opts 'new-priority)
+                              #:skip-updating-derived-priorities?
+                              (assq-ref opts 'skip-updating-derived-priorities)
+                              #:override-derived-priority
+                              (assq-ref opts 'override-derived-priority))
                              (report))
                            #:times 6
-                           #:delay 5))
+                           #:delay 5
+                           #:ignore
+                           (lambda (exn)
+                             (member (assoc-ref (exception-message exn)
+                                                "error")
+                                     '("build-already-canceled"
+                                       "build-already-processed")))))
                         matching-builds)))))
        ((build-id)
         (send-update-build-priority-request (assq-ref opts 'coordinator)