From a5c41fb01a978a195a5a0d984863790916b6c8a0 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 23 Apr 2024 11:02:59 +0100 Subject: Handle issues.guix GraphQL queries failing better --- guix-qa-frontpage/branch.scm | 199 +++++++++++++++++++----------------- guix-qa-frontpage/manage-builds.scm | 90 ++++++++-------- guix-qa-frontpage/mumi.scm | 19 +--- guix-qa-frontpage/view/home.scm | 47 ++++++--- 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"))) - (stringbool (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 (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")) -- cgit v1.2.3