diff options
| -rw-r--r-- | guix-qa-frontpage/branch.scm | 212 | ||||
| -rw-r--r-- | guix-qa-frontpage/database.scm | 62 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 92 | ||||
| -rw-r--r-- | guix-qa-frontpage/mumi.scm | 19 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 19 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/home.scm | 47 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/patches.scm | 42 |
7 files changed, 244 insertions, 249 deletions
diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm index 5874120..7ce6ef5 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 @@ -60,109 +60,125 @@ (cons branch `(("issue_number" . ,issue-number) ("issue_date" . ,(assoc-ref issue "date")) - ("blocked_by" . ,(assoc-ref issue "blocked_by"))))))) + ("blocked_by" + . ,(map (lambda (issue) + (assoc-ref issue "number")) + (or (and=> (assoc-ref issue "blocked_by") + vector->list) + '())))))))) (vector->list (mumi-search-issues ;; TODO: subject: doesn't seem to work for issues where the ;; 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)) - (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))))))))))) + (with-exception-handler + (lambda (exn) + (simple-format #t "exception listing non master branches: ~A\n" exn) + `((exception . ,(simple-format #f "~A" exn)))) + (lambda () + (with-throw-handler #t + (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))) + + ;; 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 + (or (assoc-ref (cdr a) "blocked_by") '())) + (b-blocked-by + (or (assoc-ref (cdr b) "blocked_by") '()))) + (< + (if (null? a-blocked-by) + a-initial-ordering-index + (let ((ordering-indexes + (filter-map + (lambda (blocking-issue) + (and=> + (assq-ref + initial-ordering-index-by-issue-number + blocking-issue) + 1+)) + 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) + (and=> + (assq-ref + initial-ordering-index-by-issue-number + blocking-issue) + 1+)) + b-blocked-by))) + (if (null? ordering-indexes) + b-initial-ordering-index + (apply max ordering-indexes))))))))))) + (lambda args + (display (backtrace) (current-error-port)) + (newline (current-error-port))))) + #:unwind? #t)) (define* (branch-data branch-name) (define branch-commit diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm index 5649c36..51c0255 100644 --- a/guix-qa-frontpage/database.scm +++ b/guix-qa-frontpage/database.scm @@ -465,39 +465,41 @@ SELECT data, timestamp FROM cache WHERE key = :key" (when (if (procedure? store-computed-value?) (apply store-computed-value? vals) store-computed-value?) - (database-call-with-transaction - database - (lambda (db) - (let ((cleanup-statement - (sqlite-prepare - db - " + (let ((vals-string + (call-with-output-string + (lambda (port) + (write vals port))))) + (database-call-with-transaction + database + (lambda (db) + (let ((cleanup-statement + (sqlite-prepare + db + " DELETE FROM cache WHERE key = :key" - #:cache? #t)) - (insert-statement - (sqlite-prepare - db - " + #:cache? #t)) + (insert-statement + (sqlite-prepare + db + " INSERT INTO cache (key, timestamp, data) VALUES (:key, :timestamp, :data)" - #:cache? #t))) - - (sqlite-bind-arguments - cleanup-statement - #:key string-key) - (sqlite-step cleanup-statement) - (sqlite-reset cleanup-statement) - - (sqlite-bind-arguments - insert-statement - #:key string-key - #:timestamp (time-second (current-time)) - #:data (call-with-output-string - (lambda (port) - (write vals port)))) - - (sqlite-step insert-statement) - (sqlite-reset insert-statement))))) + #:cache? #t))) + + (sqlite-bind-arguments + cleanup-statement + #:key string-key) + (sqlite-step cleanup-statement) + (sqlite-reset cleanup-statement) + + (sqlite-bind-arguments + insert-statement + #:key string-key + #:timestamp (time-second (current-time)) + #:data vals-string) + + (sqlite-step insert-statement) + (sqlite-reset insert-statement)))))) (apply values vals))) (apply values cached-values)))) diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index b8b0189..070681d 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 () @@ -478,7 +486,7 @@ #t #t tags)) - #:timeout 60))) + #:timeout 240))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response 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/server.scm b/guix-qa-frontpage/server.scm index ab0680a..8db6aae 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -40,7 +40,6 @@ #:select (parse-query-string)) #:use-module ((guix-build-coordinator utils) #:select (with-time-logging - get-port-metrics-updater call-with-delay-logging)) #:use-module ((guix-build-coordinator utils fibers) #:select (run-server/patched call-with-sigint)) @@ -98,17 +97,20 @@ (static-asset-from-store-renderer doc-dir) (static-asset-from-directory-renderer doc-dir))) + (define plain-metrics-registry + (make-metrics-registry)) + (define gc-metrics-updater! - (get-gc-metrics-updater metrics-registry)) + (get-gc-metrics-updater plain-metrics-registry)) - (define port-metrics-updater! - (get-port-metrics-updater metrics-registry)) + (define process-metrics-updater! + (get-process-metrics-updater plain-metrics-registry)) (define guile-time-metrics-updater (let ((internal-real-time - (make-gauge-metric metrics-registry "guile_internal_real_time")) + (make-gauge-metric plain-metrics-registry "guile_internal_real_time")) (internal-run-time - (make-gauge-metric metrics-registry "guile_internal_run_time"))) + (make-gauge-metric plain-metrics-registry "guile_internal_run_time"))) (lambda () (metric-set internal-real-time (get-internal-real-time)) @@ -143,14 +145,15 @@ (request-uri request)))))) (('GET "metrics") (gc-metrics-updater!) - (port-metrics-updater!) + (process-metrics-updater!) (guile-time-metrics-updater) (list (build-response #:code 200 #:headers '((content-type . (text/plain)) (vary . (accept)))) (lambda (port) - (write-metrics metrics-registry port)))) + (write-metrics metrics-registry port) + (write-metrics plain-metrics-registry port)))) (('GET "branches") (let ((branches (with-sqlite-cache 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")) diff --git a/guix-qa-frontpage/view/patches.scm b/guix-qa-frontpage/view/patches.scm index fc5c575..7fb7361 100644 --- a/guix-qa-frontpage/view/patches.scm +++ b/guix-qa-frontpage/view/patches.scm @@ -127,47 +127,7 @@ will appear first.") ,id)) (td (@ (style "vertical-align: middle;")) - ,@(cond - ((eq? status 'reviewed-looks-good) - `((span (@ (aria-label "status: darkgreen") - (class "darkgreen-dot")) - (*ENTITY* "#10004")))) - ((eq? status 'important-checks-passing) - `((span (@ (aria-label "status: green") - (class "green-dot")) - (*ENTITY* "#10004")))) - ((eq? status 'important-checks-failing) - `((span (@ (aria-label "status: red") - (class "red-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'failed-to-apply-patches) - `((span (@ (aria-label "status: darkred") - (class "darkred-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'large-number-of-builds) - `((span (@ (aria-label "status: purple") - (class "purple-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'waiting-for-build-results) - `((span (@ (aria-label "status: lightblue") - (class "lightblue-dot")) - (*ENTITY* "#127959")))) - ((eq? status 'patches-missing) - `((span (@ (aria-label "status: pink") - (class "pink-dot")) - "?"))) - ((eq? status 'guix-data-service-failed) - `((span (@ (aria-label "status: yellow") - (class "yellow-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'needs-looking-at) - `((span (@ (aria-label "status: orange") - (class "orange-dot")) - (*ENTITY* "#9888")))) - (else - `((span (@ (aria-label "status: grey") - (class "grey-dot")) - "?"))))) + ,(status->issue-status-span status)) (td (@ (style "text-align: left;")) ,(assoc-ref details "name")))))) latest-series))))))) |