From e3537c56e417d7a4dca5f77a062c066fe2d2391c Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Tue, 16 May 2023 20:48:47 +0100
Subject: Support submitting branch builds manually

---
 guix-qa-frontpage/manage-builds.scm | 108 +++++++++++++++++++++---------------
 1 file changed, 63 insertions(+), 45 deletions(-)

(limited to 'guix-qa-frontpage')

diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index 4aa01be..71decc1 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -16,6 +16,9 @@
 
             submit-builds-for-issue
 
+            default-branch-priority-for-change
+            submit-builds-for-branch
+
             start-submit-patch-builds-thread
             start-submit-branch-builds-thread
             start-submit-master-branch-system-tests-thread))
@@ -149,59 +152,74 @@
 
        (sleep 300)))))
 
+
+(define (default-branch-priority-for-change change)
+  (if (member (assoc-ref change "system")
+              '("x86_64-linux" "aarch64-linux"))
+      100
+      0))
+
+
+(define* (submit-builds-for-branch database
+                                   build-coordinator
+                                   guix-data-service
+                                   branch
+                                   #:key build-limit
+                                   (priority default-branch-priority-for-change)
+                                   (systems %systems-to-submit-builds-for))
+  (simple-format #t
+                 "considering submitting builds for branch ~A\n"
+                 branch)
+
+  (let ((derivation-changes-url
+         (branch-derivation-changes-url
+          branch
+          #:systems systems)))
+
+    (if derivation-changes-url
+        (let ((derivation-changes-data
+               change-details
+               (with-sqlite-cache
+                database
+                'branch-derivation-changes
+                derivation-changes
+                #:args
+                (list derivation-changes-url)
+                #:ttl 0)))
+
+          (when derivation-changes-data
+            (let ((target-commit
+                   (assoc-ref
+                    (assoc-ref
+                     (assoc-ref change-details
+                                "revisions")
+                     "target")
+                    "commit")))
+
+              (submit-builds-for-category build-coordinator
+                                          guix-data-service
+                                          'branch
+                                          branch
+                                          derivation-changes-data
+                                          target-commit
+                                          #:priority priority
+                                          #:threads 4))))
+        (simple-format #t "no derivation changes url for branch ~A\n"
+                       branch))))
+
 (define (start-submit-branch-builds-thread database
                                            build-coordinator
                                            guix-data-service)
   (define (submit-builds)
-    (define (priority-for-change change)
-      (if (member (assoc-ref change "system")
-                  '("x86_64-linux" "aarch64-linux"))
-          100
-          0))
-
     (simple-format #t "submitting branch builds\n")
     (let ((branches '()))
       (for-each
        (lambda (branch)
-         (simple-format #t
-                        "considering submitting builds for branch ~A\n"
-                        branch)
-
-         (let ((derivation-changes-url
-                (branch-derivation-changes-url
-                 branch
-                 #:systems %systems-to-submit-builds-for)))
-
-           (if derivation-changes-url
-               (let ((derivation-changes-data
-                      change-details
-                      (with-sqlite-cache
-                       database
-                       'branch-derivation-changes
-                       derivation-changes
-                       #:args
-                       (list derivation-changes-url)
-                       #:ttl 0)))
-
-                 (when derivation-changes-data
-                   (let ((target-commit
-                          (assoc-ref
-                           (assoc-ref
-                            (assoc-ref change-details
-                                       "revisions")
-                            "target")
-                           "commit")))
-
-                     (submit-builds-for-category build-coordinator
-                                                 guix-data-service
-                                                 'branch
-                                                 branch
-                                                 derivation-changes-data
-                                                 target-commit
-                                                 #:priority priority-for-change
-                                                 #:threads 4))))
-               (simple-format #t "no derivation changes url for branch ~A\n"
-                              branch))))
+         (submit-builds-for-branch
+          database
+          build-coordinator
+          guix-data-service
+          branch))
        branches)))
 
   (call-with-new-thread
-- 
cgit v1.2.3