Support submitting branch builds manually

2 files changed, 99 insertions, 46 deletions

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
diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in
index 471df6f..96028f1 100644
--- a/scripts/guix-qa-frontpage.in
+++ b/scripts/guix-qa-frontpage.in
@@ -110,7 +110,16 @@
                 (lambda (opt name arg result)
                   (alist-cons 'priority
                               (string->number arg)
-                              result)))))
+                              result)))
+        (option '("system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'systems
+                              (cons arg
+                                    (or (assq-ref result
+                                                  'systems)
+                                        '()))
+                              (alist-delete 'systems
+                                            result))))))
 
 (define %submit-build-default-options
   `((database . ,(string-append (getcwd)
@@ -158,6 +167,32 @@
                   550
                   350)))))))
 
+  (("submit-branch-builds" branch-name rest ...)
+   (parameterize
+       ((%git-repository-location (string-append (getcwd) "/guix.git")))
+     (let* ((opts (parse-options
+                   %submit-build-options
+                   %submit-build-default-options
+                   rest))
+            (metrics-registry (make-metrics-registry
+                               #:namespace
+                               "guixqafrontpage"))
+            (database
+             (setup-database (assq-ref opts 'database)
+                             metrics-registry)))
+
+       (submit-builds-for-branch
+        database
+        "http://127.0.0.1:8746"
+        "https://data.qa.guix.gnu.org"
+        branch-name
+        #:priority
+        (or (const (assq-ref opts 'priority))
+            default-branch-priority-for-change)
+        #:systems
+        (or (assq-ref opts 'systems)
+            %systems-to-submit-builds-for)))))
+
   ((args ...)
    (let ((opts (parse-options
                 %options