Add lots more functionality

1 files changed, 180 insertions, 0 deletions

diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
new file mode 100644
index 0000000..b6541d9
--- /dev/null
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -0,0 +1,180 @@
+(define-module (guix-qa-frontpage manage-builds)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
+  #:use-module (guix-build-coordinator utils)
+  #:use-module (guix-build-coordinator client-communication)
+  #:use-module (guix-qa-frontpage database)
+  #:use-module (guix-qa-frontpage patchwork)
+  #:use-module (guix-qa-frontpage guix-data-service)
+  #:export (start-submit-patch-builds-thread))
+
+(define (start-submit-patch-builds-thread database
+                                          build-coordinator
+                                          guix-data-service)
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (simple-format #t "submitting patch builds\n")
+       (let ((series (with-sqlite-cache
+                      database
+                      'latest-patchwork-series-by-issue
+                      latest-patchwork-series-by-issue
+                      #:ttl 3000)))
+
+         (for-each
+          (match-lambda
+            ((issue-number . series)
+             (simple-format #t
+                            "considering submitting builds for issue ~A\n"
+                            issue-number)
+
+             (let ((derivation-changes
+                    change-details
+                    (with-sqlite-cache
+                     database
+                     'derivation-changes
+                     patch-series-derivation-changes
+                     #:args
+                     (list (patch-series-derivation-changes-url series))
+                     #:ttl 6000)))
+
+               (when derivation-changes
+                 (let ((target-commit
+                        (assoc-ref
+                         (assoc-ref
+                          (assoc-ref change-details
+                                     "revisions")
+                          "target")
+                         "commit")))
+
+                   (submit-builds-for-issue build-coordinator
+                                            guix-data-service
+                                            issue-number
+                                            derivation-changes
+                                            target-commit))))))
+          (take series 10)))))))
+
+(define* (submit-build build-coordinator guix-data-service derivation
+                       #:key (priority 0) (tags '()))
+  (retry-on-error
+   (lambda ()
+     (let ((response
+            (send-submit-build-request
+             build-coordinator
+             derivation
+             (list guix-data-service)
+             #f
+             priority
+             #t
+             #t
+             #t
+             tags)))
+       (let ((no-build-submitted-response
+              (assoc-ref response "no-build-submitted")))
+         (if no-build-submitted-response
+             (simple-format #t "skipped: ~A\n"
+                            no-build-submitted-response)
+             (simple-format #t "build submitted as ~A\n"
+                            (assoc-ref response "build-submitted"))))))
+   ;; The TTL Guix uses for transient failures fetching substitutes is 10
+   ;; minutes, so we need to retry for longer than that
+   #:times 30
+   #:delay 30))
+
+(define (cancel-issue-builds-not-for-revision build-coordinator
+                                              issue
+                                              revision
+                                              derivations)
+  (define (builds-after id)
+    (vector->list
+     (assoc-ref
+      (request-builds-list build-coordinator
+                           #:tags
+                           `(((key . category)
+                              (value . package))
+                             ((key . issue)
+                              (value . ,issue)))
+                           #:not-tags
+                           `(((key . revision)
+                              (value . ,revision)))
+                           #:canceled #f
+                           #:processed #f
+                           #:limit 1000
+                           #:after-id id)
+      "builds")))
+
+  (simple-format (current-error-port)
+                 "canceling builds for issue ~A and not revision ~A\n"
+                 issue
+                 revision)
+  (let loop ((builds (builds-after #f)))
+    (for-each
+     (lambda (build-details)
+       (unless (member derivations
+                       (assoc-ref build-details "derivation-name"))
+         (retry-on-error
+          (lambda ()
+            (send-cancel-build-request build-coordinator
+                                       (assoc-ref build-details "uuid")))
+          #:times 6
+          #:delay 15)
+         (simple-format (current-error-port)
+                        "canceled ~A\n"
+                        (assoc-ref build-details "uuid"))))
+     builds)
+    (unless (null? builds)
+      (loop (builds-after
+             (assoc-ref (last builds) "uuid"))))))
+
+(define* (submit-builds-for-issue build-coordinator
+                                  guix-data-service
+                                  issue
+                                  derivation-changes
+                                  target-commit)
+  (define systems
+    '("x86_64-linux"
+      "i686-linux"
+      "aarch64-linux"
+      "armhf-linux"))
+
+  (define target-derivations
+    (fold (lambda (package result)
+            (fold
+             (lambda (change result)
+               (if (and (string=? (assoc-ref change "target")
+                                  "")
+                        (member (assoc-ref change "system")
+                                systems)
+                        (eq? (vector-length
+                              (assoc-ref change "builds"))
+                             0))
+                   (cons (assoc-ref change "derivation-file-name")
+                         result)
+                   result))
+             result
+             (vector->list
+              (assoc-ref package "target"))))
+          '()
+          derivation-changes))
+
+  (for-each (lambda (derivation)
+              (submit-build build-coordinator
+                            guix-data-service
+                            derivation
+                            #:priority 0
+                            #:tags
+                            `(((key . category)
+                               (value . package))
+                              ((key . issue)
+                               (value . ,issue))
+                              ((key . revision)
+                               (value . ,target-commit)))))
+            target-derivations)
+
+  (cancel-issue-builds-not-for-revision
+   build-coordinator
+   issue
+   target-commit
+   target-derivations))