Add the ability to submit builds manually for an issue

Without a limit for the number of builds.

1 files changed, 116 insertions, 66 deletions

diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in
index d758a94..e5ee962 100644
--- a/scripts/guix-qa-frontpage.in
+++ b/scripts/guix-qa-frontpage.in
@@ -100,78 +100,128 @@
     (submit-builds . #f)
     (manage-patch-branches . #f)))
 
-(define (parse-options args)
+(define %submit-build-options
+  (list (option '("database") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'database
+                              arg
+                              result)))
+        (option '("priority") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'priority
+                              (string->number arg)
+                              result)))))
+
+(define %submit-build-default-options
+  `((database . ,(string-append (getcwd)
+                                "/guix_qa_frontpage.db"))))
+
+(define (parse-options options defaults args)
   (args-fold
-   args %options
+   args options
    (lambda (opt name arg result)
      (error "unrecognized option" name))
    (lambda (arg result)
      (error "extraneous argument" arg))
-   %default-options))
+   defaults))
 
 (setvbuf (current-output-port) 'line)
 (setvbuf (current-error-port) 'line)
 
-(let ((opts (parse-options (cdr (program-arguments)))))
-  (when (assq-ref opts 'repl)
-    ((@@ (ice-9 top-repl) call-with-sigint)
-     start-repl)
-    (exit 0))
-
-  (let ((repl-port (assoc-ref opts 'listen-repl)))
-    (when repl-port
-      (spawn-server (make-tcp-server-socket #:port repl-port))))
-
-  (let ((pid-file (assq-ref opts 'pid-file)))
-    (when pid-file
-      (call-with-output-file pid-file
-        (lambda (port)
-          (simple-format port "~A\n" (getpid))))))
-
-  ;; Provide some visual space between the startup output and the
-  ;; server starting
-  (simple-format #t "\n\nStarting the server on http://~A:~A/\n\n"
-                 (assq-ref opts 'host)
-                 (assq-ref opts 'port))
-
-  (parameterize
-      ((%git-repository-location (string-append (getcwd) "/guix.git")))
-    (let* ((metrics-registry (make-metrics-registry
-                              #:namespace
-                              "guixqafrontpage"))
-           (database
-            (setup-database (assq-ref opts 'database)
-                            metrics-registry))
-
-           (patch-issues-to-show 350))
-
-      (start-refresh-patch-branches-data-thread
-       database
-       #:number-of-series-to-refresh
-       (+ patch-issues-to-show 50))
-      (start-refresh-non-patch-branches-data-thread database)
-
-      (when (assq-ref opts 'submit-builds)
-        (start-submit-patch-builds-thread database
-                                          "http://127.0.0.1:8746"
-                                          "https://data.qa.guix.gnu.org"
-                                          #:series-count
-                                          patch-issues-to-show)
-        (start-submit-branch-builds-thread database
-                                           "http://127.0.0.1:8746"
-                                           "https://data.qa.guix.gnu.org")
-        (start-submit-master-branch-system-tests-thread database
-                                                        "http://127.0.0.1:8746"
-                                                        "https://data.qa.guix.gnu.org"))
-
-      (when (assq-ref opts 'manage-patch-branches)
-        (start-manage-patch-branches-thread database
-                                            #:series-count patch-issues-to-show))
-
-      (start-guix-qa-frontpage-web-server
-       (assq-ref opts 'port)
-       (assq-ref opts 'host)
-       (assq-ref opts 'assets-directory)
-       database
-       metrics-registry
-       #:controller-args `(#:patch-issues-to-show ,patch-issues-to-show)))))
+(match (cdr (program-arguments))
+  (("submit-issue-builds" issue-number-str rest ...)
+   (parameterize
+       ((%git-repository-location (string-append (getcwd) "/guix.git")))
+     (let* ((opts (parse-options
+                   %submit-build-options
+                   %submit-build-default-options
+                   rest))
+            (issue-number
+             (string->number issue-number-str))
+            (metrics-registry (make-metrics-registry
+                               #:namespace
+                               "guixqafrontpage"))
+            (database
+             (setup-database (assq-ref opts 'database)
+                             metrics-registry)))
+
+       (submit-builds-for-issue
+        database
+        "http://127.0.0.1:8746"
+        "https://data.qa.guix.gnu.org"
+        issue-number
+        #:priority
+        (or (const (assq-ref opts 'priority))
+            (lambda (priority-for-change change)
+              (if (member (assoc-ref change "system")
+                          '("x86_64-linux" "aarch64-linux"))
+                  550
+                  350)))))))
+
+  ((args ...)
+   (let ((opts (parse-options
+                %options
+                %default-options
+                args)))
+     (when (assq-ref opts 'repl)
+       ((@@ (ice-9 top-repl) call-with-sigint)
+        start-repl)
+       (exit 0))
+
+     (let ((repl-port (assoc-ref opts 'listen-repl)))
+       (when repl-port
+         (spawn-server (make-tcp-server-socket #:port repl-port))))
+
+     (let ((pid-file (assq-ref opts 'pid-file)))
+       (when pid-file
+         (call-with-output-file pid-file
+           (lambda (port)
+             (simple-format port "~A\n" (getpid))))))
+
+     ;; Provide some visual space between the startup output and the
+     ;; server starting
+     (simple-format #t "\n\nStarting the server on http://~A:~A/\n\n"
+                    (assq-ref opts 'host)
+                    (assq-ref opts 'port))
+
+     (parameterize
+         ((%git-repository-location (string-append (getcwd) "/guix.git")))
+       (let* ((metrics-registry (make-metrics-registry
+                                 #:namespace
+                                 "guixqafrontpage"))
+              (database
+               (setup-database (assq-ref opts 'database)
+                               metrics-registry))
+
+              (patch-issues-to-show 350))
+
+         (start-refresh-patch-branches-data-thread
+          database
+          #:number-of-series-to-refresh
+          (+ patch-issues-to-show 50))
+         (start-refresh-non-patch-branches-data-thread database)
+
+         (when (assq-ref opts 'submit-builds)
+           (start-submit-patch-builds-thread database
+                                             "http://127.0.0.1:8746"
+                                             "https://data.qa.guix.gnu.org"
+                                             #:series-count
+                                             patch-issues-to-show)
+           (start-submit-branch-builds-thread database
+                                              "http://127.0.0.1:8746"
+                                              "https://data.qa.guix.gnu.org")
+           (start-submit-master-branch-system-tests-thread database
+                                                           "http://127.0.0.1:8746"
+                                                           "https://data.qa.guix.gnu.org"))
+
+         (when (assq-ref opts 'manage-patch-branches)
+           (start-manage-patch-branches-thread database
+                                               #:series-count patch-issues-to-show))
+
+         (start-guix-qa-frontpage-web-server
+          (assq-ref opts 'port)
+          (assq-ref opts 'host)
+          (assq-ref opts 'assets-directory)
+          database
+          metrics-registry
+          #:controller-args `(#:patch-issues-to-show ,patch-issues-to-show)))))))