Handle issues.guix GraphQL queries failing betterHEADmaster

4 files changed, 188 insertions, 167 deletions

diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm
index 5874120..be579f3 100644
--- a/guix-qa-frontpage/branch.scm
+++ b/guix-qa-frontpage/branch.scm
@@ -49,7 +49,7 @@
            (lambda (m)
              (match:substring m 1))))
 
-  (define merge-issues-by-branch
+  (define (merge-issues-by-branch)
     (filter-map
      (lambda (issue)
        (let ((branch (issue-title->branch
@@ -67,102 +67,109 @@
        ;; subject/title has changed
        "\"Request for merging\" is:open"))))
 
-  (let ((branches
-         (map
-          (lambda (branch)
-            (let ((name (assoc-ref branch "name")))
-              (cons name
-                    (append
-                     (or (assoc-ref merge-issues-by-branch name)
-                         '())
-                     (alist-delete "name" branch)))))
-          (remove
-           (lambda (branch)
-             (or (string=? (assoc-ref branch "name")
-                           "master")
-                 (string-prefix? "version-"
-                                 (assoc-ref branch "name"))
-                 (string=? (assoc-ref branch "commit")
-                           "")))
-           (list-branches
-            (list-branches-url 2))))))
-    (let* ((initial-ordered-branches
-            (stable-sort
-             branches
-             (lambda (a b)
-               (let ((a-has-issue
-                      (->bool (assoc-ref (cdr a) "issue_number")))
-                     (b-has-issue
-                      (->bool (assoc-ref (cdr b) "issue_number"))))
-                 (if (and a-has-issue b-has-issue)
-                     (let ((a-date
-                            (assoc-ref (cdr a) "issue_date"))
-                           (b-date
-                            (assoc-ref (cdr b) "issue_date")))
-                       (string<? a-date b-date))
-                     a-has-issue)))))
-           (initial-ordering-index-by-branch
-            (map (lambda (index branch)
-                   (cons (car branch) index))
+  (with-exception-handler
+      (lambda (exn)
+        `((exception . ,(simple-format #f "~A" exn))))
+    (lambda ()
+      (let* ((merge-issues
+              (merge-issues-by-branch))
+             (branches
+              (map
+               (lambda (branch)
+                 (let ((name (assoc-ref branch "name")))
+                   (cons name
+                         (append
+                          (or (assoc-ref merge-issues name)
+                              '())
+                          (alist-delete "name" branch)))))
+               (remove
+                (lambda (branch)
+                  (or (string=? (assoc-ref branch "name")
+                                "master")
+                      (string-prefix? "version-"
+                                      (assoc-ref branch "name"))
+                      (string=? (assoc-ref branch "commit")
+                                "")))
+                (list-branches
+                 (list-branches-url 2))))))
+        (let* ((initial-ordered-branches
+                (stable-sort
+                 branches
+                 (lambda (a b)
+                   (let ((a-has-issue
+                          (->bool (assoc-ref (cdr a) "issue_number")))
+                         (b-has-issue
+                          (->bool (assoc-ref (cdr b) "issue_number"))))
+                     (if (and a-has-issue b-has-issue)
+                         (let ((a-date
+                                (assoc-ref (cdr a) "issue_date"))
+                               (b-date
+                                (assoc-ref (cdr b) "issue_date")))
+                           (string<? a-date b-date))
+                         a-has-issue)))))
+               (initial-ordering-index-by-branch
+                (map (lambda (index branch)
+                       (cons (car branch) index))
+                     (iota (length initial-ordered-branches))
+                     initial-ordered-branches))
+               (initial-ordering-index-by-issue-number
+                (filter-map
+                 (lambda (index branch)
+                   (and=> (assoc-ref (cdr branch) "issue_number")
+                          (lambda (issue-number)
+                            (cons issue-number index))))
                  (iota (length initial-ordered-branches))
-                 initial-ordered-branches))
-           (initial-ordering-index-by-issue-number
-            (filter-map
-             (lambda (index branch)
-               (and=> (assoc-ref (cdr branch) "issue_number")
-                      (lambda (issue-number)
-                        (cons issue-number index))))
-             (iota (length initial-ordered-branches))
-             initial-ordered-branches)))
-
-      ;; The idea with issues blocking others is to create a linked list,
-      ;; however I think it's possible to have a loop in the blocking directed
-      ;; graph, so try to not completely fail if this is the case.
-      (stable-sort
-       initial-ordered-branches
-       (lambda (a b)
-         (let ((a-initial-ordering-index
-                (assq-ref initial-ordering-index-by-branch
-                          (car a)))
-               (b-initial-ordering-index
-                (assq-ref initial-ordering-index-by-branch
-                          (car b)))
-
-               (a-blocked-by
-                (map (lambda (issue)
-                       (assoc-ref issue "number"))
-                     (or (and=> (assoc-ref (cdr a) "blocked_by")
-                                vector->list)
-                         '())))
-               (b-blocked-by
-                (map (lambda (issue)
-                       (assoc-ref issue "number"))
-                     (or (and=> (assoc-ref (cdr b) "blocked_by")
-                                vector->list)
-                         '()))))
-           (<
-            (if (null? a-blocked-by)
-                a-initial-ordering-index
-                (let ((ordering-indexes
-                       (filter-map
-                        (lambda (blocking-issue)
-                          (assq-ref initial-ordering-index-by-issue-number
-                                    blocking-issue))
-                        a-blocked-by)))
-                  (if (null? ordering-indexes)
-                      a-initial-ordering-index
-                      (apply max ordering-indexes))))
-            (if (null? b-blocked-by)
-                b-initial-ordering-index
-                (let ((ordering-indexes
-                       (filter-map
-                        (lambda (blocking-issue)
-                          (assq-ref initial-ordering-index-by-issue-number
-                                    blocking-issue))
-                        b-blocked-by)))
-                  (if (null? ordering-indexes)
-                      b-initial-ordering-index
-                      (apply max ordering-indexes)))))))))))
+                 initial-ordered-branches)))
+
+          ;; The idea with issues blocking others is to create a linked list,
+          ;; however I think it's possible to have a loop in the blocking directed
+          ;; graph, so try to not completely fail if this is the case.
+          (stable-sort
+           initial-ordered-branches
+           (lambda (a b)
+             (let ((a-initial-ordering-index
+                    (assq-ref initial-ordering-index-by-branch
+                              (car a)))
+                   (b-initial-ordering-index
+                    (assq-ref initial-ordering-index-by-branch
+                              (car b)))
+
+                   (a-blocked-by
+                    (map (lambda (issue)
+                           (assoc-ref issue "number"))
+                         (or (and=> (assoc-ref (cdr a) "blocked_by")
+                                    vector->list)
+                             '())))
+                   (b-blocked-by
+                    (map (lambda (issue)
+                           (assoc-ref issue "number"))
+                         (or (and=> (assoc-ref (cdr b) "blocked_by")
+                                    vector->list)
+                             '()))))
+               (<
+                (if (null? a-blocked-by)
+                    a-initial-ordering-index
+                    (let ((ordering-indexes
+                           (filter-map
+                            (lambda (blocking-issue)
+                              (assq-ref initial-ordering-index-by-issue-number
+                                        blocking-issue))
+                            a-blocked-by)))
+                      (if (null? ordering-indexes)
+                          a-initial-ordering-index
+                          (apply max ordering-indexes))))
+                (if (null? b-blocked-by)
+                    b-initial-ordering-index
+                    (let ((ordering-indexes
+                           (filter-map
+                            (lambda (blocking-issue)
+                              (assq-ref initial-ordering-index-by-issue-number
+                                        blocking-issue))
+                            b-blocked-by)))
+                      (if (null? ordering-indexes)
+                          b-initial-ordering-index
+                          (apply max ordering-indexes)))))))))))
+    #:unwind? #t))
 
 (define* (branch-data branch-name)
   (define branch-commit
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index b8b0189..1d9a512 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -390,47 +390,55 @@
      branches))
 
   (define (submit-branch-builds)
-    (let* ((branches
-            (take*
-             (filter
-              (match-lambda
-                ((name . details)
-                 (->bool (assoc-ref details "issue_number"))))
-              (with-sqlite-cache
-               database
-               'list-non-master-branches
-               list-non-master-branches
-               #:ttl 0))
-             2))
-           (branch-names
-            (map car branches)))
-
-      (let* ((branches-with-builds-previously-submitted
-              (select-from-builds-to-cancel-later
-               database
-               "branch"))
-             (branches-with-builds-to-cancel
-              (lset-difference
-               string=?
-               branches-with-builds-previously-submitted
-               branch-names)))
-        (unless (null? branches-with-builds-to-cancel)
-          (cancel-branch-builds branches-with-builds-to-cancel)))
-
-      (let* ((substitute-availability
-              systems-with-low-substitute-availability
-              package-reproducibility
-              (with-sqlite-cache
-               database
-               'master-branch-data
-               master-branch-data
-               #:ttl 6000
-               #:version 2)))
-        (if (null? systems-with-low-substitute-availability)
-            (submit-builds branch-names)
-            (simple-format
-             (current-error-port)
-             "waiting for master branch substitutes before submitting branch builds\n")))))
+    (let ((all-branches
+           (with-sqlite-cache
+            database
+            'list-non-master-branches
+            list-non-master-branches
+            #:ttl 0)))
+      (if (assq-ref all-branches 'exception)
+          (simple-format
+           (current-error-port)
+           "unable to submit branch builds, exception in list-non-master-branches: ~A\n"
+           (assq-ref all-branches 'exception))
+
+          (let* ((branches
+                  (take*
+                   (filter
+                    (match-lambda
+                      ((name . details)
+                       (->bool (assoc-ref details "issue_number"))))
+                    all-branches)
+                   2))
+                 (branch-names
+                  (map car branches)))
+
+            (let* ((branches-with-builds-previously-submitted
+                    (select-from-builds-to-cancel-later
+                     database
+                     "branch"))
+                   (branches-with-builds-to-cancel
+                    (lset-difference
+                     string=?
+                     branches-with-builds-previously-submitted
+                     branch-names)))
+              (unless (null? branches-with-builds-to-cancel)
+                (cancel-branch-builds branches-with-builds-to-cancel)))
+
+            (let* ((substitute-availability
+                    systems-with-low-substitute-availability
+                    package-reproducibility
+                    (with-sqlite-cache
+                     database
+                     'master-branch-data
+                     master-branch-data
+                     #:ttl 6000
+                     #:version 2)))
+              (if (null? systems-with-low-substitute-availability)
+                  (submit-builds branch-names)
+                  (simple-format
+                   (current-error-port)
+                   "waiting for master branch substitutes before submitting branch builds\n")))))))
 
   (call-with-new-thread
    (lambda ()
diff --git a/guix-qa-frontpage/mumi.scm b/guix-qa-frontpage/mumi.scm
index 6baa199..94c1842 100644
--- a/guix-qa-frontpage/mumi.scm
+++ b/guix-qa-frontpage/mumi.scm
@@ -60,20 +60,11 @@
 
 
 (define (mumi-search-issues query)
-  (with-exception-handler
-      (lambda (exn)
-        (simple-format
-         (current-error-port)
-         "exception when searching issues: ~A\n"
-         exn)
-        #f)
-    (lambda ()
-      (let ((response
-             (graphql-http-get "https://issues.guix.gnu.org/graphql"
-                               `(document (query (#(issues #:search ,query) number title date open (blocked_by number)))))))
-        (assoc-ref response
-                   "issues")))
-    #:unwind? #t))
+  (let ((response
+         (graphql-http-get "https://issues.guix.gnu.org/graphql"
+                           `(document (query (#(issues #:search ,query) number title date open (blocked_by number)))))))
+    (assoc-ref response
+               "issues")))
 
 (define (mumi-issue-open? number)
   (let ((response
diff --git a/guix-qa-frontpage/view/home.scm b/guix-qa-frontpage/view/home.scm
index a25e486..3a1c1d9 100644
--- a/guix-qa-frontpage/view/home.scm
+++ b/guix-qa-frontpage/view/home.scm
@@ -23,6 +23,13 @@ dd {
 dt {
     margin-left: 2em;
 }
+
+td.bad {
+  padding: 0.05rem 0.65rem;
+  font-weight: bold;
+
+  border: 0.3rem dashed red;
+}
 "))
    #:body
    `((main
@@ -75,22 +82,30 @@ dt {
           (tr (th "Branch")
               (th "Request to merge")))
          (tbody
-          ,@(append-map
-             (match-lambda
-               ((branch . details)
-                (let ((issue-number
-                       (assoc-ref details "issue_number")))
-                  `((tr
-                     (td (a (@ (href ,(string-append "/branch/" branch))
-                               (style "font-family: monospace;"))
-                            ,branch))
-                     (td ,@(if issue-number
-                               `((a (@ (href ,(string-append
-                                               "https://issues.guix.gnu.org/"
-                                               (number->string issue-number))))
-                                    "#" ,issue-number))
-                               '())))))))
-             branches)))))
+          ,@(if (assq-ref branches 'exception)
+                `((tr
+                   (td (@ (colspan 2) (class "bad")
+                          (style "white-space: normal;"))
+                       "Exception fetching branches:"
+                       (br)
+                       ,(assq-ref branches 'exception))))
+
+                (append-map
+                 (match-lambda
+                   ((branch . details)
+                    (let ((issue-number
+                           (assoc-ref details "issue_number")))
+                      `((tr
+                         (td (a (@ (href ,(string-append "/branch/" branch))
+                                   (style "font-family: monospace;"))
+                                ,branch))
+                         (td ,@(if issue-number
+                                   `((a (@ (href ,(string-append
+                                                   "https://issues.guix.gnu.org/"
+                                                   (number->string issue-number))))
+                                        "#" ,issue-number))
+                                   '())))))))
+                 branches))))))
       (h2 "Topics")
       (div
        (@ (class "row"))