diff options
Diffstat (limited to 'guix-qa-frontpage')
| -rw-r--r-- | guix-qa-frontpage/branch.scm | 322 | ||||
| -rw-r--r-- | guix-qa-frontpage/database.scm | 162 | ||||
| -rw-r--r-- | guix-qa-frontpage/debbugs.scm | 1 | ||||
| -rw-r--r-- | guix-qa-frontpage/derivation-changes.scm | 116 | ||||
| -rw-r--r-- | guix-qa-frontpage/git-repository.scm | 25 | ||||
| -rw-r--r-- | guix-qa-frontpage/guix-data-service.scm | 286 | ||||
| -rw-r--r-- | guix-qa-frontpage/issue.scm | 158 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 583 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 121 | ||||
| -rw-r--r-- | guix-qa-frontpage/mumi.scm | 184 | ||||
| -rw-r--r-- | guix-qa-frontpage/patchwork.scm | 122 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 229 | ||||
| -rw-r--r-- | guix-qa-frontpage/utils.scm | 213 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/branch.scm | 12 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/branches.scm | 22 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/home.scm | 47 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/issue.scm | 9 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/patches.scm | 46 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/shared.scm | 107 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/util.scm | 17 |
20 files changed, 1553 insertions, 1229 deletions
diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm index 5874120..6276476 100644 --- a/guix-qa-frontpage/branch.scm +++ b/guix-qa-frontpage/branch.scm @@ -23,11 +23,17 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 threads) + #:use-module (web uri) #:use-module (prometheus) #:use-module ((guix-build-coordinator utils) #:select (with-time-logging)) + #:use-module ((guix-build-coordinator utils fibers) + #:select (retry-on-error)) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module (fibers) + #:use-module (knots non-blocking) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage mumi) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage guix-data-service) @@ -36,12 +42,14 @@ #:use-module (guix-qa-frontpage manage-builds) #:export (list-non-master-branches + branch-derivation-changes-data + branch-derivation-changes-data/all-systems branch-data master-branch-data get-systems-with-low-substitute-availability - start-refresh-non-patch-branches-data-thread)) + start-refresh-non-patch-branches-data-fiber)) (define (list-non-master-branches) (define (issue-title->branch title) @@ -49,7 +57,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 +68,149 @@ (cons branch `(("issue_number" . ,issue-number) ("issue_date" . ,(assoc-ref issue "date")) - ("blocked_by" . ,(assoc-ref issue "blocked_by"))))))) + ("blocked_by" + . ,(list->vector + (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-prefix? "wip-" + (assoc-ref branch "name")) + (string=? (assoc-ref branch "commit") + ""))) + (get-git-remote-branches "origin"))))) + (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 + (vector->list + (or (assoc-ref (cdr a) "blocked_by") #()))) + (b-blocked-by + (vector->list + (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-derivation-changes-data revisions system) + (with-exception-handler guix-data-service-error->sexp + (lambda () + (compare-package-derivations + (compare-package-derivations-url + revisions + #:systems (list system)))) + #:unwind? #t + #:unwind-for-type &guix-data-service-error)) + +(define (branch-derivation-changes-data/all-systems revisions) + (with-exception-handler guix-data-service-error->sexp + (lambda () + (compare-package-derivations + (compare-package-derivations-url + revisions + #:systems %systems-to-submit-builds-for))) + #:unwind? #t + #:unwind-for-type &guix-data-service-error)) (define* (branch-data branch-name) (define branch-commit @@ -199,24 +247,20 @@ #:unwind? #t #:unwind-for-type &guix-data-service-error)) - (derivation-changes-data - (with-exception-handler guix-data-service-error->sexp - (lambda () - (let ((data - (compare-package-derivations - (compare-package-derivations-url - revisions - #:systems %systems-to-submit-builds-for)))) - - (with-throw-handler #t - (lambda () - (derivation-changes - data - %systems-to-submit-builds-for)) - (lambda _ - (backtrace))))) - #:unwind? #t - #:unwind-for-type &guix-data-service-error)) + (derivation-changes-counts + (append-map + (lambda (system) + (let ((derivation-changes-data + (retry-on-error + (lambda () + (branch-derivation-changes-data revisions system)) + #:times 1))) + (if (assq-ref derivation-changes-data 'exception) + derivation-changes-data + (derivation-changes-counts + derivation-changes-data + (list system))))) + %systems-to-submit-builds-for)) (substitute-availability (with-exception-handler guix-data-service-error->sexp @@ -232,7 +276,7 @@ (package-reproducibility-url branch-commit)))) (values revisions - derivation-changes-data + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master?)) @@ -242,11 +286,19 @@ (define* (master-branch-data) (let* ((substitute-availability (package-substitute-availability - "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-substitute-availability.json")) + (string-append + %data-service-url-base + "/repository/" + (number->string %data-service-guix-repository-id) + "/branch/master/latest-processed-revision/package-substitute-availability.json"))) (package-reproducibility (guix-data-service-request - "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-reproducibility.json")) + (string-append + %data-service-url-base + "/repository/" + (number->string %data-service-guix-repository-id) + "/branch/master/latest-processed-revision/package-reproducibility.json"))) (systems-with-low-substitute-availability (get-systems-with-low-substitute-availability @@ -285,15 +337,17 @@ (lambda (details) ;; TODO: Don't hardcode this (string=? - "https://bordeaux.guix.gnu.org" - (assoc-ref - (assoc-ref details "server") - "url"))) + "bordeaux.guix.gnu.org" + (uri-host + (string->uri + (assoc-ref + (assoc-ref details "server") + "url"))))) (vector->list substitute-availability)) "availability")))) -(define (start-refresh-non-patch-branches-data-thread database - metrics-registry) +(define (start-refresh-non-patch-branches-data-fiber database + metrics-registry) (define frequency (* 30 60)) @@ -345,7 +399,9 @@ (define (refresh-data) (simple-format (current-error-port) "refreshing non-patch branches data...\n") - (update-repository!) + (non-blocking + (lambda () + (update-repository!))) (let ((branches (with-sqlite-cache @@ -359,11 +415,10 @@ (string-prefix? "version-" (assoc-ref branch "name")))) (list-branches - (list-branches-url 2)))) + (list-branches-url %data-service-guix-repository-id)))) #:ttl 0))) - (n-par-for-each - 1 + (for-each (lambda (branch) (let ((branch-name (assoc-ref branch "name"))) @@ -421,13 +476,8 @@ "master" master-branch-substitute-availability))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "branch data refresh")) - (const #t)) - (while #t (let ((start-time (current-time))) (with-exception-handler diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm index 5649c36..06ce3bd 100644 --- a/guix-qa-frontpage/database.scm +++ b/guix-qa-frontpage/database.scm @@ -28,15 +28,15 @@ #:use-module (sqlite3) #:use-module (fibers) #:use-module (prometheus) + #:use-module (knots queue) + #:use-module (knots thread-pool) #:use-module (guix narinfo) #:use-module (guix derivations) #:use-module ((guix-build-coordinator utils) #:select (log-delay call-with-delay-logging)) #:use-module ((guix-build-coordinator utils fibers) - #:select (retry-on-error - make-worker-thread-channel - call-with-worker-thread)) + #:select (retry-on-error)) #:use-module (guix-qa-frontpage guix-data-service) #:export (setup-database @@ -57,13 +57,16 @@ delete-create-branch-for-issue-log)) (define-record-type <database> - (make-database database-file reader-thread-channel writer-thread-channel + (make-database database-file reader-thread-set writer-thread-set + writer-thread-set-channel metrics-registry) database? (database-file database-file) - (reader-thread-channel database-reader-thread-channel) - (writer-thread-channel database-writer-thread-channel) - (metrics-registry database-metrics-registry)) + (reader-thread-set database-reader-thread-set) + (writer-thread-set database-writer-thread-set) + (writer-thread-set-channel database-writer-thread-set-channel + set-database-writer-thread-set-channel!) + (metrics-registry database-metrics-registry)) (define* (db-open database #:key (write? #t)) @@ -143,28 +146,28 @@ CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs ( (sqlite-close db)) - (let ((reader-thread-channel - (make-worker-thread-channel + (let ((reader-thread-pool + (make-thread-pool + (min (max (current-processor-count) + 32) + 128) + #:thread-initializer (lambda () (let ((db (db-open database-file #:write? #f))) (sqlite-exec db "PRAGMA busy_timeout = 5000;") (list db))) - #:destructor + #:thread-destructor (lambda (db) (sqlite-close db)) - #:lifetime 50000 + #:thread-lifetime 50000 #:name "db read" - #:parallelism - (min (max (current-processor-count) - 32) - 128) #:delay-logger (let ((delay-metric (make-histogram-metric metrics-registry "datastore_read_delay_seconds"))) - (lambda (seconds-delayed) + (lambda (seconds-delayed proc) (metric-observe delay-metric ;; TODO exact->inexact to work around ;; a bug in guile-prometheus where @@ -180,30 +183,31 @@ CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs ( #:log-exception? (lambda (exn) (not (guix-data-service-error? exn))))) - (writer-thread-channel - (make-worker-thread-channel + (writer-thread-pool + (make-thread-pool + ;; SQLite doesn't support parallel writes + 1 + #:thread-initializer (lambda () (let ((db (db-open database-file))) (sqlite-exec db "PRAGMA busy_timeout = 5000;") (sqlite-exec db "PRAGMA foreign_keys = ON;") (list db))) - #:destructor + #:thread-destructor (lambda (db) (db-optimize db database-file) (sqlite-close db)) - #:lifetime 500 + #:thread-lifetime 500 #:name "db write" - ;; SQLite doesn't support parallel writes - #:parallelism 1 #:delay-logger (let ((delay-metric (make-histogram-metric metrics-registry "datastore_write_delay_seconds"))) - (lambda (seconds-delayed) + (lambda (seconds-delayed proc) (metric-observe delay-metric ;; TODO exact->inexact to work around ;; a bug in guile-prometheus where @@ -218,8 +222,9 @@ CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs ( seconds-delayed))))))) (make-database database-file - reader-thread-channel - writer-thread-channel + reader-thread-pool + writer-thread-pool + (thread-pool-channel writer-thread-pool) metrics-registry))) (define (db-optimize db db-filename) @@ -244,8 +249,8 @@ PRAGMA optimize;"))) (define (database-optimize database) (retry-on-error (lambda () - (call-with-worker-thread - (database-writer-thread-channel database) + (call-with-thread + (database-writer-thread-set database) (lambda (db) (db-optimize db @@ -254,6 +259,14 @@ PRAGMA optimize;"))) #:delay 5)) (define (database-spawn-fibers database) + ;; Queue messages to the writer thread, so that they're handled in a first + ;; come first served manor + (set-database-writer-thread-set-channel! + database + (spawn-queueing-fiber + (thread-pool-channel + (database-writer-thread-set database)))) + (spawn-fiber (lambda () (while #t @@ -313,10 +326,10 @@ PRAGMA optimize;"))) (apply values vals)))) #:unwind? #t)))) - (match (call-with-worker-thread + (match (call-with-thread ((if readonly? - database-reader-thread-channel - database-writer-thread-channel) + database-reader-thread-set + database-writer-thread-set) database) (lambda (db) (let ((start-time (get-internal-real-time))) @@ -337,7 +350,11 @@ PRAGMA optimize;"))) duration-seconds) (current-error-port))) - (cons duration-seconds vals))))))) + (cons duration-seconds vals)))))) + #:channel + (if readonly? + #f + (database-writer-thread-set-channel database))) ((duration vals ...) (apply values vals)))) @@ -421,8 +438,8 @@ DELETE FROM cache WHERE key = :key" (error "must specify a ttl")) (let ((cached-values - (call-with-worker-thread - (database-reader-thread-channel database) + (call-with-thread + (database-reader-thread-set database) (lambda (db) (let ((statement (sqlite-prepare @@ -455,49 +472,56 @@ SELECT data, timestamp FROM cache WHERE key = :key" (if (eq? cached-values 'noval) (call-with-values (lambda () - (call-with-worker-thread - (database-reader-thread-channel database) + (call-with-thread + (database-reader-thread-set database) (lambda (db) - (call-with-delay-logging - proc - #:args args)))) + (with-throw-handler #t + (lambda () + (call-with-delay-logging + proc + #:args args)) + (lambda args + (display (backtrace) (current-error-port)) + (newline (current-error-port))))))) (lambda vals (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))) + #:cache? #t))) - (sqlite-bind-arguments - cleanup-statement - #:key string-key) - (sqlite-step cleanup-statement) - (sqlite-reset cleanup-statement) + (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-bind-arguments + insert-statement + #:key string-key + #:timestamp (time-second (current-time)) + #:data vals-string) - (sqlite-step insert-statement) - (sqlite-reset insert-statement))))) + (sqlite-step insert-statement) + (sqlite-reset insert-statement)))))) (apply values vals))) (apply values cached-values)))) @@ -546,8 +570,8 @@ WHERE category_name = :name AND category_value = :value" #t) (define (select-from-builds-to-cancel-later database category-name) - (call-with-worker-thread - (database-reader-thread-channel database) + (call-with-thread + (database-reader-thread-set database) (lambda (db) (let ((statement (sqlite-prepare @@ -602,8 +626,8 @@ VALUES (:issue, :log)" (sqlite-reset insert-statement))))) (define (select-create-branch-for-issue-log database issue) - (call-with-worker-thread - (database-reader-thread-channel database) + (call-with-thread + (database-reader-thread-set database) (lambda (db) (let ((statement (sqlite-prepare diff --git a/guix-qa-frontpage/debbugs.scm b/guix-qa-frontpage/debbugs.scm index 656865d..b1614db 100644 --- a/guix-qa-frontpage/debbugs.scm +++ b/guix-qa-frontpage/debbugs.scm @@ -24,6 +24,7 @@ fetch-issues-with-guix-tag)) (define (debbugs-get-issues-with-guix-usertag) + ;; TODO Ideally this would be non-blocking (soap-invoke (%gnu) get-usertag "guix")) (define (fetch-issues-with-guix-tag tag) diff --git a/guix-qa-frontpage/derivation-changes.scm b/guix-qa-frontpage/derivation-changes.scm index cda0084..eab021e 100644 --- a/guix-qa-frontpage/derivation-changes.scm +++ b/guix-qa-frontpage/derivation-changes.scm @@ -21,7 +21,7 @@ #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:export (categorise-packages - derivation-changes)) + derivation-changes-counts)) (define (categorise-packages derivation-changes side) (define (vector-member? s v) @@ -82,7 +82,7 @@ '() derivation-changes)) -(define (derivation-changes derivation-changes all-systems) +(define (derivation-changes-counts derivation-changes all-systems) (define categorised-base-packages-by-system (categorise-packages (assoc-ref derivation-changes "derivation_changes") @@ -93,61 +93,57 @@ "derivation_changes") "target")) - (define counts - (if (null? categorised-target-packages-by-system) - '() - (map - (match-lambda - ((system . categorised-target-builds) - (let ((categorised-base-builds - (assoc-ref categorised-base-packages-by-system - system))) - (cons - system - (map (lambda (side) - (cons side - (map (lambda (status) - (cons status - (length - (or - (assoc-ref - (if (eq? side 'base) - categorised-base-builds - categorised-target-builds) - status) - '())))) - '(succeeding failing blocked unknown)))) - '(base target)))))) - (sort - (append categorised-target-packages-by-system - (filter-map - (lambda (system) - (if (assoc-ref categorised-target-packages-by-system - system) - #f - (cons system '()))) - all-systems)) - (lambda (a b) - (let ((a-key (car a)) - (b-key (car b))) - (cond - ((and (string? a-key) - (string? b-key)) - (< (or (list-index - (lambda (s) - (string=? (car a) s)) - all-systems) - 10) - (or (list-index - (lambda (s) - (string=? (car b) s)) - all-systems) - 10))) - ((and (pair? a-key) - (pair? b-key)) - (string<? (cdr a-key) - (cdr b-key))) - (else #f)))))))) - - `(,@derivation-changes - (counts . ,counts))) + (if (null? categorised-target-packages-by-system) + '() + (map + (match-lambda + ((system . categorised-target-builds) + (let ((categorised-base-builds + (assoc-ref categorised-base-packages-by-system + system))) + (cons + system + (map (lambda (side) + (cons side + (map (lambda (status) + (cons status + (length + (or + (assoc-ref + (if (eq? side 'base) + categorised-base-builds + categorised-target-builds) + status) + '())))) + '(succeeding failing blocked unknown)))) + '(base target)))))) + (sort + (append categorised-target-packages-by-system + (filter-map + (lambda (system) + (if (assoc-ref categorised-target-packages-by-system + system) + #f + (cons system '()))) + all-systems)) + (lambda (a b) + (let ((a-key (car a)) + (b-key (car b))) + (cond + ((and (string? a-key) + (string? b-key)) + (< (or (list-index + (lambda (s) + (string=? (car a) s)) + all-systems) + 10) + (or (list-index + (lambda (s) + (string=? (car b) s)) + all-systems) + 10))) + ((and (pair? a-key) + (pair? b-key)) + (string<? (cdr a-key) + (cdr b-key))) + (else #f)))))))) diff --git a/guix-qa-frontpage/git-repository.scm b/guix-qa-frontpage/git-repository.scm index ec6996f..6ff3eb2 100644 --- a/guix-qa-frontpage/git-repository.scm +++ b/guix-qa-frontpage/git-repository.scm @@ -23,7 +23,8 @@ get-commit get-git-branch-head-committer-date - get-git-merge-base)) + get-git-merge-base + get-git-remote-branches)) (define %git-repository-location (make-parameter #f)) @@ -50,7 +51,7 @@ (invoke "git" "remote" "add" "origin" "https://git.savannah.gnu.org/git/guix.git") (invoke "git" "remote" "add" "patches" - "git@git.guix-patches.cbaines.net:guix-patches") + "git@git.qa.guix.gnu.org:guix-patches") (invoke "git" "config" "user.name" "Guix Patches Tester") (invoke "git" "config" "user.email" ""))))))) @@ -135,3 +136,23 @@ (first lines))) (loop (read-line pipe) (cons line lines)))))))) + +(define (get-git-remote-branches remote) + (with-bare-git-repository + (lambda () + (let ((pipe (open-pipe* OPEN_READ + "git" "ls-remote" "--heads" remote))) + (let loop ((line (read-line pipe)) + (result '())) + (if (eof-object? line) + (begin + (close-pipe pipe) + + result) + (let ((commit (string-take line 40)) + (branch (string-drop line 52))) + (loop (read-line pipe) + (cons + `(("name" . ,branch) + ("commit" . ,commit)) + result))))))))) diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm index 9bf7997..8540524 100644 --- a/guix-qa-frontpage/guix-data-service.scm +++ b/guix-qa-frontpage/guix-data-service.scm @@ -4,22 +4,33 @@ #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) + #:use-module (ice-9 binary-ports) #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (zlib) #:use-module (json) + #:use-module (fibers) + #:use-module (knots timeout) + #:use-module (knots non-blocking) #:use-module ((guix-build-coordinator utils fibers) #:select (retry-on-error)) #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage patchwork) #:use-module (guix-qa-frontpage manage-patch-branches) - #:export (&guix-data-service-error + #:export (%data-service-url-base + %data-service-guix-repository-id + + &guix-data-service-error guix-data-service-error? guix-data-service-error-response-body guix-data-service-error-response-code + guix-data-service-error-url guix-data-service-error->sexp + guix-data-service-error-summary + guix-data-service-error-sexp->error + guix-data-service-error-invalid-query? guix-data-service-request @@ -51,84 +62,122 @@ package-reproducibility-url)) +(define %data-service-url-base + "https://data.qa.guix.gnu.org") + +(define %data-service-guix-repository-id 1) + (define-exception-type &guix-data-service-error &error make-guix-data-service-error guix-data-service-error? (response-body guix-data-service-error-response-body) - (response-code guix-data-service-error-response-code)) + (response-code guix-data-service-error-response-code) + (url guix-data-service-error-url)) (define (guix-data-service-error->sexp exn) - `((exception . guix-data-service-invalid-parameters) - (invalid_query_parameters - . - ,(filter-map - (match-lambda - ((param . val) - (and=> - (assoc-ref val "invalid_value") - (lambda (value) - (let ((message - (assoc-ref val "message"))) - (cons - param - `((value . ,value) - (error - ;; Convert the HTML error messages - ;; to something easier to handle - . ,(cond - ((string-contains message - "failed to process revision") - 'failed-to-process-revision) - ((string-contains message - "yet to process revision") - 'yet-to-process-revision) - ((string=? message "unknown commit") - 'unknown-commit) - (else - 'unknown-error)))))))))) - (assoc-ref - (guix-data-service-error-response-body exn) - "query_parameters"))))) - -;; Returns the port as well as the raw socket -(define* (open-socket-for-uri* uri - #:key (verify-certificate? #t)) - (define tls-wrap - (@@ (web client) tls-wrap)) - - (define https? - (eq? 'https (uri-scheme uri))) - - (define plain-uri - (if https? - (build-uri - 'http - #:userinfo (uri-userinfo uri) - #:host (uri-host uri) - #:port (or (uri-port uri) 443) - #:path (uri-path uri) - #:query (uri-query uri) - #:fragment (uri-fragment uri)) - uri)) - - (let ((s (open-socket-for-uri plain-uri))) - (values - (if https? - (tls-wrap s (uri-host uri) - #:verify-certificate? verify-certificate?) - s) - s))) + (cond + ((string=? (or (assoc-ref (guix-data-service-error-response-body exn) + "error") + "") + "invalid query") + `((exception . guix-data-service-invalid-parameters) + (invalid_query_parameters + . + ,(filter-map + (match-lambda + ((param . val) + (and=> + (assoc-ref val "invalid_value") + (lambda (value) + (let ((message + (assoc-ref val "message"))) + (cons + param + `((value . ,value) + (error + ;; Convert the HTML error messages + ;; to something easier to handle + . ,(cond + ((string-contains message + "failed to process revision") + 'failed-to-process-revision) + ((string-contains message + "yet to process revision") + 'yet-to-process-revision) + ((string=? message "unknown commit") + 'unknown-commit) + (else + 'unknown-error)))))))))) + (assoc-ref + (guix-data-service-error-response-body exn) + "query_parameters"))))) + (else + `((exception . guix-data-service-exception) + (body . ,(guix-data-service-error-response-body exn)) + (url . ,(guix-data-service-error-url exn)))))) + +(define (guix-data-service-error-summary exn) + (cond + ((string=? (or (assoc-ref (guix-data-service-error-response-body exn) + "error") + "") + "invalid query") + (string-join + (filter-map + (match-lambda + ((param . val) + (and=> + (assoc-ref val "invalid_value") + (lambda (value) + (let ((message + (assoc-ref val "message"))) + (simple-format + #f + "~A: ~A" + param + ;; Convert the HTML error messages + ;; to something easier to handle + (cond + ((string-contains message + "failed to process revision") + 'failed-to-process-revision) + ((string-contains message + "yet to process revision") + 'yet-to-process-revision) + ((string=? message "unknown commit") + 'unknown-commit) + (else + 'unknown-error)))))))) + (assoc-ref + (guix-data-service-error-response-body exn) + "query_parameters")) + ", ")) + (else + (simple-format #f "~A" (guix-data-service-error-response-body exn))))) + +(define (guix-data-service-error-sexp->error sexp) + (make-guix-data-service-error + (if (eq? (assq-ref sexp 'exception) + 'guix-data-service-invalid-parameters) + `(("error" . "invalid-query") + ,@sexp) + sexp) + #f + #f)) + +(define (guix-data-service-error-invalid-query? exn) + (and + (guix-data-service-error? exn) + (string=? + (or (assoc-ref (guix-data-service-error-response-body exn) + "error") + "") + "invalid-query"))) (define* (guix-data-service-request url #:key (retry-times 0) (retry-delay 5)) (define (make-request) (let ((port - socket - (open-socket-for-uri* (string->uri url)))) - - ;; This can't be done earlier as tls-wrap/guile-gnutls doesn't support - ;; handshake on a non blocking socket - (let ((flags (fcntl socket F_GETFL))) - (fcntl socket F_SETFL (logior O_NONBLOCK flags))) + (non-blocking-open-socket-for-uri (string->uri url)))) (let ((response body @@ -137,35 +186,49 @@ '((accept-encoding . ((1 . "gzip")))) #:streaming? #t #:port port))) - (if (eq? (response-code response) - 404) - #f - (let ((json-body - (match (response-content-encoding response) - (('gzip) - ;; Stop fibers from triggering dynamic-wind in (zlib) - (call-with-blocked-asyncs - (lambda () - (call-with-zlib-input-port - body - json->scm - #:format 'gzip)))) - (_ - (json->scm body))))) - (if (or (> (response-code response) - 400) - (assoc-ref json-body "error")) - (raise-exception - (make-guix-data-service-error json-body - (response-code response))) - (values json-body - response))))))) + (cond + ((eq? (response-code response) 404) + #f) + ((not (eq? (first (response-content-type response)) + 'application/json)) + (raise-exception + (make-guix-data-service-error + (utf8->string + (match (response-content-encoding response) + (('gzip) + (call-with-zlib-input-port* + body + get-bytevector-all + #:format 'gzip)) + (_ + (get-bytevector-all body)))) + (response-code response) + url))) + (else + (let ((json-body + (match (response-content-encoding response) + (('gzip) + (call-with-zlib-input-port* + body + json->scm + #:format 'gzip)) + (_ + (json->scm body))))) + (if (or (> (response-code response) + 400) + (assoc-ref json-body "error")) + (raise-exception + (make-guix-data-service-error json-body + (response-code response) + url)) + (values json-body + response)))))))) (if (= 0 retry-times) (make-request) (retry-on-error (lambda () - (with-fibers-port-timeouts + (with-port-timeouts make-request #:timeout 120)) #:times retry-times @@ -179,12 +242,13 @@ #:key system target no-build-from-build-server) (string-append - "https://data.qa.guix.gnu.org/revision/" + %data-service-url-base + "/revision/" commit "/package-derivations.json?" "system=" system "&target=" target - "&field=" "(no-additional-fields)" + "&field=" "no-additional-fields" "&all_results=" "on" (if no-build-from-build-server (string-append @@ -193,7 +257,8 @@ (define* (compare-package-derivations-url base-and-target-refs #:key systems) (string-append - "https://data.qa.guix.gnu.org/compare/package-derivations.json?" + %data-service-url-base + "/compare/package-derivations.json?" "base_commit=" (assq-ref base-and-target-refs 'base) "&target_commit=" (assq-ref base-and-target-refs 'target) (string-join @@ -206,7 +271,8 @@ (define* (compare-package-cross-derivations-url base-and-target-refs #:key systems) (string-append - "https://data.qa.guix.gnu.org/compare/package-derivations.json?" + %data-service-url-base + "/compare/package-derivations.json?" "base_commit=" (assq-ref base-and-target-refs 'base) "&target_commit=" (assq-ref base-and-target-refs 'target) (string-join @@ -225,7 +291,8 @@ (define* (revision-comparison-url base-and-target-refs #:key (json? #t)) (string-append - "https://data.qa.guix.gnu.org/compare" + %data-service-url-base + "/compare" (if json? ".json" "") "?" "base_commit=" (assq-ref base-and-target-refs 'base) @@ -235,7 +302,8 @@ (guix-data-service-request url)) (define (list-branches-url repository-id) - (simple-format #f "https://data.qa.guix.gnu.org/repository/~A.json" + (simple-format #f "~A/repository/~A.json" + %data-service-url-base repository-id)) (define (list-branches url) @@ -248,8 +316,9 @@ (let ((json-body (guix-data-service-request (string-append - "https://data.qa.guix.gnu.org" - "/repository/2" + %data-service-url-base + "/repository/" + (number->string %data-service-guix-repository-id) "/branch/" branch "/latest-processed-revision.json")))) (assoc-ref @@ -259,7 +328,8 @@ (define (branch-revisions-url repository-id branch-name) (simple-format #f - "https://data.qa.guix.gnu.org/repository/~A/branch/~A.json" + "~A/repository/~A/branch/~A.json" + %data-service-url-base repository-id branch-name)) @@ -272,7 +342,8 @@ (define* (revision-details-url commit) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A.json" + "~A/revision/~A.json" + %data-service-url-base commit)) (define (revision-details url) @@ -281,7 +352,8 @@ (define* (revision-system-tests-url commit #:key (system "x86_64-linux")) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A/system-tests.json?system=~A" + "~A/revision/~A/system-tests.json?system=~A" + %data-service-url-base commit system)) @@ -294,7 +366,8 @@ (define* (package-substitute-availability-url commit) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A/package-substitute-availability.json" + "~A/revision/~A/package-substitute-availability.json" + %data-service-url-base commit)) (define (package-substitute-availability url) @@ -307,5 +380,6 @@ (define* (package-reproducibility-url commit) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A/package-reproducibility.json" + "~A/revision/~A/package-reproducibility.json" + %data-service-url-base commit)) diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm index 6ceb733..beed41f 100644 --- a/guix-qa-frontpage/issue.scm +++ b/guix-qa-frontpage/issue.scm @@ -23,9 +23,13 @@ #:use-module (ice-9 threads) #:use-module (prometheus) #:use-module ((guix-build-coordinator utils) - #:select (with-time-logging)) + #:select (with-time-logging call-with-delay-logging)) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module (fibers) + #:use-module (knots non-blocking) + #:use-module (knots parallelism) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage manage-patch-branches) @@ -40,7 +44,7 @@ issue-patches-overall-status issue-data - start-refresh-patch-branches-data-thread)) + start-refresh-patch-branches-data-fiber)) (define reviewed-looks-good-status 'reviewed-looks-good) (define good-status 'important-checks-passing) @@ -177,79 +181,73 @@ (with-exception-handler (lambda (exn) (if (guix-data-service-error? exn) - `((exception . guix-data-service-invalid-parameters) - (invalid_query_parameters - . - ,(filter-map - (match-lambda - ((param . val) - (and=> - (assoc-ref val "invalid_value") - (lambda (value) - (let ((message - (assoc-ref val "message"))) - (cons - param - `((value . ,value) - (error - ;; Convert the HTML error messages - ;; to something easier to handle - . ,(cond - ((string-contains message - "failed to process revision") - 'failed-to-process-revision) - ((string-contains message - "yet to process revision") - 'yet-to-process-revision) - (else - 'unknown)))))))))) - (assoc-ref - (guix-data-service-error-response-body exn) - "query_parameters")))) + (guix-data-service-error->sexp exn) `((exception . ,(simple-format #f "~A" exn))))) thunk #:unwind? #t)) (let* ((base-and-target-refs - (get-issue-branch-base-and-target-refs - number)) + (call-with-delay-logging + get-issue-branch-base-and-target-refs + #:args (list number))) (derivation-changes-raw-data (if base-and-target-refs (call-with-data-service-error-handling (lambda () - (compare-package-derivations - (compare-package-derivations-url - base-and-target-refs - #:systems %systems-to-submit-builds-for)))) + (call-with-delay-logging + compare-package-derivations + #:args + (list + (compare-package-derivations-url + base-and-target-refs + #:systems %systems-to-submit-builds-for))))) #f)) (derivation-changes-data (if (and derivation-changes-raw-data (not (assq-ref derivation-changes-raw-data 'exception))) - (derivation-changes - derivation-changes-raw-data - %systems-to-submit-builds-for) + (cons + (cons 'counts + (call-with-delay-logging + derivation-changes-counts + #:args + (list + derivation-changes-raw-data + %systems-to-submit-builds-for))) + derivation-changes-raw-data) #f)) (cross-derivation-changes-raw-data (if base-and-target-refs (call-with-data-service-error-handling (lambda () - (compare-package-derivations - (compare-package-cross-derivations-url - base-and-target-refs - #:systems %systems-to-submit-builds-for)))) + (call-with-delay-logging + compare-package-derivations + #:args + (list + (compare-package-cross-derivations-url + base-and-target-refs + #:systems %systems-to-submit-builds-for))))) #f)) (cross-derivation-changes-data (if (and cross-derivation-changes-raw-data (not (assq-ref cross-derivation-changes-raw-data 'exception))) - (derivation-changes - cross-derivation-changes-raw-data - %systems-to-submit-builds-for) + (cons + (cons 'counts + (call-with-delay-logging + derivation-changes-counts + #:args + (list + cross-derivation-changes-raw-data + %systems-to-submit-builds-for))) + cross-derivation-changes-raw-data) #f)) (builds-missing? (if derivation-changes-data - (builds-missing-for-derivation-changes? - (assoc-ref derivation-changes-raw-data - "derivation_changes")) + (call-with-delay-logging + builds-missing-for-derivation-changes? + #:args + (list + (assoc-ref derivation-changes-raw-data + "derivation_changes"))) #t)) (comparison-details (and @@ -288,9 +286,11 @@ "query_parameters")))) `((exception . ,(simple-format #f "~A" exn))))) (lambda () - (revision-comparison - (revision-comparison-url - base-and-target-refs))) + (call-with-delay-logging + revision-comparison + #:args (list + (revision-comparison-url + base-and-target-refs)))) #:unwind? #t)))) (values @@ -303,12 +303,25 @@ builds-missing? comparison-details))) -(define* (start-refresh-patch-branches-data-thread +(define* (start-refresh-patch-branches-data-fiber database metrics-registry #:key number-of-series-to-refresh) (define frequency - (* 15 60)) + (* 30 60)) + + (define issue-data/fiberized+cached + (fiberize + (lambda (issue-number) + (with-sqlite-cache + database + 'issue-data + issue-data + #:args + (list issue-number) + #:version 3 + #:ttl (/ frequency 2))) + #:parallelism 2)) (define (refresh-data) (simple-format (current-error-port) @@ -326,10 +339,22 @@ (take latest-series number-of-series-to-refresh) latest-series))) - (update-repository!) + (for-each + (match-lambda + ((issue-number . data) + (with-sqlite-cache + database + 'latest-patchwork-series-for-issue + (const data) + #:args (list issue-number) + #:ttl 0))) + latest-series) - (n-par-for-each - 5 + (non-blocking + (lambda () + (update-repository!))) + + (fibers-batch-for-each (match-lambda ((issue-number . series-data) (with-exception-handler @@ -348,14 +373,7 @@ change-details builds-missing? comparison-details - (with-sqlite-cache - database - 'issue-data - issue-data - #:args - (list issue-number) - #:version 3 - #:ttl (/ frequency 2)))) + (issue-data/fiberized+cached issue-number))) (with-sqlite-cache database @@ -385,15 +403,11 @@ #:args (list issue-number) #:ttl 0))) #:unwind? #t))) + 50 series-to-refresh))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "data refresh")) - (const #t)) - (while #t (let ((start-time (current-time))) (with-exception-handler diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index b8b0189..82e2675 100644 --- a/guix-qa-frontpage/manage-builds.scm +++ b/guix-qa-frontpage/manage-builds.scm @@ -7,6 +7,9 @@ #:use-module (ice-9 threads) #:use-module (ice-9 exceptions) #:use-module (fibers) + #:use-module (knots parallelism) + #:use-module (knots non-blocking) + #:use-module (knots timeout) #:use-module (prometheus) #:use-module (guix sets) #:use-module ((guix build syscalls) @@ -33,8 +36,11 @@ default-branch-priority-for-change submit-builds-for-branch + submit-build + %fiberized-submit-build + start-submit-patch-builds-fiber - start-submit-branch-builds-thread + start-submit-branch-builds-fiber start-submit-master-branch-system-tests-thread)) (define %systems-to-submit-builds-for @@ -42,11 +48,18 @@ "i686-linux" "aarch64-linux" "armhf-linux" - "powerpc64le-linux" - "i586-gnu")) + "riscv64-linux" + ;; Don't submit powerpc64le-linux builds as the single build machine + ;; available isn't running enough at the moment + ;; "powerpc64le-linux" + ;; Builds for the hurd can't be reliably done at the moment, so skip + ;; submitting them + ;; "i586-gnu" + )) (define %systems-with-expected-low-substitute-availability - '("i586-gnu" + '("armhf-linux" + "i586-gnu" "riscv64-linux" "powerpc64le-linux")) @@ -54,6 +67,9 @@ (* (length %systems-to-submit-builds-for) 600)) +(define %fiberized-submit-build + (make-parameter #f)) + (define* (submit-builds-for-issue database build-coordinator @@ -83,8 +99,10 @@ (current-error-port) "failed fetching derivation changes for issue ~A: ~A\n" issue-number - exn) - + (if (and (guix-data-service-error? exn) + (= (guix-data-service-error-response-code exn) 200)) + (guix-data-service-error-summary exn) + exn)) #f) (lambda () (with-sqlite-cache @@ -185,7 +203,7 @@ issues-with-builds-to-cancel)) (simple-format #t "submitting patch builds\n") - (for-each + (fibers-batch-for-each (lambda (issue-number) (submit-builds-for-issue database @@ -194,6 +212,7 @@ issue-number #:priority priority-for-change #:build-limit %patches-builds-limit)) + 2 first-n-series-issue-numbers))) (spawn-fiber @@ -203,7 +222,7 @@ (lambda (exn) (simple-format (current-error-port) - "exception in submit patch builds thread: ~A\n" + "exception in submit patch builds fiber: ~A\n" exn)) (lambda () (with-throw-handler #t @@ -233,6 +252,12 @@ (sleep 300))))) +(define (shuffle-derivations-and-priorities! derivations-and-priorities) + (sort! + derivations-and-priorities + (lambda (a b) ; less + (string<? (first a) (first b))))) + (define* (submit-builds-for-branch database build-coordinator guix-data-service @@ -248,114 +273,123 @@ (get-commit (string-append "origin/" branch))) (merge-base - (get-git-merge-base - (get-commit "origin/master") - branch-commit)) + (non-blocking + (lambda () + (get-git-merge-base + (get-commit "origin/master") + branch-commit)))) (revisions `((base . ,merge-base) - (target . ,branch-commit))) - - (derivation-changes-url - (compare-package-derivations-url - revisions - #:systems %systems-to-submit-builds-for))) - - (if derivation-changes-url - (let ((derivation-changes-data - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "failed fetching derivation changes for branch ~A: ~A\n" - branch - exn) - - #f) - (lambda () - (with-sqlite-cache - database - 'branch-derivation-changes - compare-package-derivations - #:args - (list derivation-changes-url) - #:ttl 0)) - #:unwind? #t))) - - (if derivation-changes-data - (let ((target-commit - (assoc-ref - (assoc-ref - (assoc-ref derivation-changes-data - "revisions") - "target") - "commit"))) - - (insert-into-builds-to-cancel-later database - "branch" - branch) - (let ((derivations-and-priorities - build-ids-to-keep-set - (derivation-changes->builds-to-keep-and-submit - derivation-changes-data - priority))) - (submit-builds-for-category build-coordinator - guix-data-service - 'branch - branch - derivations-and-priorities - build-ids-to-keep-set - target-commit - #:threads 4))) - (begin - (simple-format - (current-error-port) - "attempting to submit builds for all derivations for branch ~A\n" - branch) + (target . ,branch-commit)))) + + (let ((derivation-changes-vectors + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "failed fetching derivation changes for branch ~A: ~A\n" + branch + exn) + + #f) + (lambda () + (map (lambda (system) + (retry-on-error + (lambda () + (let ((data + (branch-derivation-changes-data revisions system))) + (if (assq-ref data 'exception) + (raise-exception + (guix-data-service-error-sexp->error data)) + (assoc-ref data "derivation_changes")))) + #:no-retry guix-data-service-error-invalid-query? + #:times 2 + #:delay 15)) + %systems-to-submit-builds-for)) + #:unwind? #t))) + + (if derivation-changes-vectors + (begin + (insert-into-builds-to-cancel-later database + "branch" + branch) + (let ((derivations-and-priorities + build-ids-to-keep-set + (derivation-changes-vectors->builds-to-keep-and-submit + derivation-changes-vectors + priority))) + (submit-builds-for-category build-coordinator + guix-data-service + 'branch + branch + (shuffle-derivations-and-priorities! + derivations-and-priorities) + build-ids-to-keep-set + branch-commit + #:skip-updating-derived-priorities? #t))) + (begin + (simple-format + (current-error-port) + "attempting to submit builds for all derivations for branch ~A\n" + branch) + + (let ((derivations-and-priorities + (shuffle-derivations-and-priorities! + (fold + (lambda (system result) + (let ((package-derivations + ;; This can be #f for unprcessed revisions as + ;; the data service gives a 404 + (guix-data-service-request + (package-derivations-url + branch-commit + #:system system + #:target "" + #:no-build-from-build-server "2")))) + (if (eq? package-derivations #f) + (begin + (simple-format + (current-error-port) + "missing package derivation data for ~A\n" + branch) + '()) + (vector-fold-right + (lambda (_ result derivation) + (cons + (list + (assoc-ref derivation "derivation") + (if (number? priority) + priority + (priority derivation))) + result)) + result + (assoc-ref package-derivations + "derivations"))))) + '() + %systems-to-submit-builds-for)))) + (insert-into-builds-to-cancel-later database + "branch" + branch) - (let ((derivations-and-priorities - (fold - (lambda (system result) - (vector-fold-right - (lambda (_ result derivation) - (cons - (list - (assoc-ref derivation "derivation") - (if (number? priority) - priority - (priority derivation))) - result)) - result - (assoc-ref - (guix-data-service-request - (package-derivations-url - branch-commit - #:system system - #:target "" - #:no-build-from-build-server "2")) - "derivations"))) - '() - %systems-to-submit-builds-for))) - (submit-builds-for-category build-coordinator - guix-data-service - 'branch - branch - derivations-and-priorities - (set) - branch-commit - #:threads 4))))) - (simple-format #t "no derivation changes url for branch ~A\n" - branch)))) + (submit-builds-for-category build-coordinator + guix-data-service + 'branch + branch + derivations-and-priorities + (set) + branch-commit + #:skip-updating-derived-priorities? #t))))))) (define (take* lst n) (if (< (length lst) n) lst (take lst n))) -(define (start-submit-branch-builds-thread database - build-coordinator - guix-data-service - metrics-registry) +(define (start-submit-branch-builds-fiber database + build-coordinator + guix-data-service + metrics-registry) (define (cancel-branch-builds branches) (for-each (lambda (branch) @@ -390,61 +424,66 @@ 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) + ;; TODO The builds for the first branch should be mostly + ;; complete before submitting builds for any others + 1)) + (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 + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "branch builds")) - (const #t)) - (while #t (with-exception-handler (lambda (exn) (simple-format (current-error-port) - "exception in submit branch builds thread: ~A\n" + "exception in submit branch builds fiber: ~A\n" exn)) (lambda () (with-throw-handler #t @@ -462,11 +501,12 @@ (sleep 3600))))) (define* (submit-build build-coordinator guix-data-service derivation - #:key (priority 0) (tags '())) + #:key (priority 0) (tags '()) + skip-updating-derived-priorities?) (retry-on-error (lambda () (let ((response - (with-fibers-port-timeouts + (with-port-timeouts (lambda () (send-submit-build-request build-coordinator @@ -477,8 +517,10 @@ #t #t #t - tags)) - #:timeout 60))) + tags + #:skip-updating-derived-priorities? + skip-updating-derived-priorities?)) + #:timeout 240))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response @@ -514,7 +556,7 @@ "canceling builds for ~A ~A\n" category-name category-value) - (with-fibers-port-timeouts + (with-port-timeouts (lambda () (let loop ((uuids-batch (fetch-build-uuids))) (for-each @@ -542,7 +584,7 @@ (unless (null? uuids-batch) (loop (fetch-build-uuids))))) - #:timeout 60) + #:timeout 120) (simple-format (current-error-port) "finshed canceling builds for ~A ~A\n" category-name @@ -576,7 +618,7 @@ category-name category-value revision) - (with-fibers-port-timeouts + (with-port-timeouts (lambda () (let loop ((uuids-batch (fetch-build-uuids))) (let ((builds-to-cancel @@ -606,7 +648,7 @@ (unless (null? builds-to-cancel) (loop (fetch-build-uuids)))))) - #:timeout 60) + #:timeout 120) (simple-format (current-error-port) "finished canceling builds for ~A ~A and not revision ~A\n" category-name @@ -635,71 +677,103 @@ '() derivation-changes))) + (define (derivation-changes->builds-to-keep-and-submit derivation-changes priority) - (let loop ((changes - (vector-fold - (lambda (_ result package) - (append! result - (vector->list - (assoc-ref package "target")))) - '() - (assoc-ref derivation-changes "derivation_changes"))) - (builds-to-submit-details '()) - (build-ids-to-keep-set (set))) - - (if (null? changes) + (derivation-changes-vectors->builds-to-keep-and-submit + (list (assoc-ref derivation-changes "derivation_changes")) + priority)) + +(define (derivation-changes-vectors->builds-to-keep-and-submit all-derivation-changes-vectors + priority) + (define (process-change? change) + (and (string=? (assoc-ref change "target") + "") + (member (assoc-ref change "system") + %systems-to-submit-builds-for))) + + (define (skip-submitting-build? change) + (vector-any + (lambda (build) + (let ((build-status + (assoc-ref build "status"))) + (if (string=? build-status "scheduled") + (not (assoc-ref + build + "build_for_equivalent_derivation")) + (member build-status + '("started" "succeeded" "failed"))))) + (assoc-ref change "builds"))) + + ;; So bad, but hopefully keeps memory usage down compared to converting to + ;; lists and flattening + (let loop1 ((derivation-changes-vectors all-derivation-changes-vectors) + (builds-to-submit-details '()) + (build-ids-to-keep-set (set))) + (if (null? derivation-changes-vectors) (values builds-to-submit-details build-ids-to-keep-set) - (let ((change (first changes))) - (if (and (string=? (assoc-ref change "target") - "") - (member (assoc-ref change "system") - %systems-to-submit-builds-for)) - (loop (cdr changes) - (if (vector-any - (lambda (build) - (let ((build-status - (assoc-ref build "status"))) - (if (string=? build-status "scheduled") - (not (assoc-ref - build - "build_for_equivalent_derivation")) - (member build-status - '("started" "succeeded" "failed"))))) - (assoc-ref change "builds")) - builds-to-submit-details ; build exists - (cons - (list (assoc-ref change "derivation-file-name") - (if (number? priority) - priority - (priority change))) - builds-to-submit-details)) - (fold (lambda (build result) - (let ((build-status - (assoc-ref build "status"))) - (if (or (string=? build-status "started") - (and (string=? build-status "scheduled") - ;; Cancel and replace builds for - ;; equivalent derivations, since - ;; the derivation might be removed - ;; from the data service preventing - ;; the build from starting. - (not - (assoc-ref - build - "build_for_equivalent_derivation")))) - (set-insert - (assoc-ref build "build_server_build_id") - result) - result))) - build-ids-to-keep-set - (vector->list - (assoc-ref change "builds")))) - - (loop (cdr changes) - builds-to-submit-details - build-ids-to-keep-set)))))) + (let* ((changes-vector + (car derivation-changes-vectors)) + (changes-vector-length + (vector-length changes-vector))) + (let loop2 ((changes-index 0) + (builds-to-submit-details builds-to-submit-details) + (build-ids-to-keep-set build-ids-to-keep-set)) + (if (= changes-index changes-vector-length) + (loop1 (cdr derivation-changes-vectors) + builds-to-submit-details + build-ids-to-keep-set) + (let* ((change-target-vector + (assoc-ref (vector-ref changes-vector changes-index) + "target")) + (change-target-vector-length + (vector-length change-target-vector))) + (let loop3 ((change-target-index 0) + (builds-to-submit-details builds-to-submit-details) + (build-ids-to-keep-set build-ids-to-keep-set)) + (if (= change-target-index change-target-vector-length) + (loop2 (1+ changes-index) + builds-to-submit-details + build-ids-to-keep-set) + (let ((change + (vector-ref change-target-vector + change-target-index))) + (if (process-change? change) + (loop3 (1+ change-target-index) + (if (skip-submitting-build? change) + builds-to-submit-details ; build exists + (cons + (list (assoc-ref change "derivation-file-name") + (if (number? priority) + priority + (priority change))) + builds-to-submit-details)) + (fold (lambda (build result) + (let ((build-status + (assoc-ref build "status"))) + (if (or (string=? build-status "started") + (and (string=? build-status "scheduled") + ;; Cancel and replace builds for + ;; equivalent derivations, since + ;; the derivation might be removed + ;; from the data service preventing + ;; the build from starting. + (not + (assoc-ref + build + "build_for_equivalent_derivation")))) + (set-insert + (assoc-ref build "build_server_build_id") + result) + result))) + build-ids-to-keep-set + (vector->list + (assoc-ref change "builds")))) + + (loop3 (1+ change-target-index) + builds-to-submit-details + build-ids-to-keep-set)))))))))))) (define* (submit-builds-for-category build-coordinator guix-data-service @@ -710,32 +784,30 @@ target-commit #:key build-limit (build-count-priority-penalty (const 0)) - (threads 1)) + skip-updating-derived-priorities?) (define (submit-builds build-details build-ids-to-keep-set) + (define submit-build/fiberized + (%fiberized-submit-build)) + (define submit-single (match-lambda ((derivation priority) - (submit-build build-coordinator - guix-data-service - derivation - #:priority priority - #:tags - `(((key . category) - (value . package)) - ((key . ,category-name) - (value . ,category-value)) - ((key . revision) - (value . ,target-commit))))))) - - (if (= threads 1) - (for-each - submit-single - build-details) - (n-par-for-each - threads - submit-single - build-details))) + (submit-build/fiberized build-coordinator + guix-data-service + derivation + #:priority priority + #:tags + `(((key . category) + (value . package)) + ((key . ,category-name) + (value . ,category-value)) + ((key . revision) + (value . ,target-commit))) + #:skip-updating-derived-priorities? + skip-updating-derived-priorities?)))) + + (fibers-for-each submit-single build-details)) (let ((builds-to-submit-count (length derivations-and-priorities))) @@ -744,14 +816,18 @@ category-name category-value) - ;; Cancel builds first, as some of the builds we want to submit might be - ;; for the same outputs as ones we're going to cancel. - (cancel-builds-not-for-revision - build-coordinator - category-name - category-value - target-commit - build-ids-to-keep-set) + (retry-on-error + (lambda () + ;; Cancel builds first, as some of the builds we want to submit might be + ;; for the same outputs as ones we're going to cancel. + (cancel-builds-not-for-revision + build-coordinator + category-name + category-value + target-commit + build-ids-to-keep-set)) + #:times 3 + #:delay 2) (if (or (not build-limit) (< builds-to-submit-count @@ -814,7 +890,8 @@ (assoc-ref revision-details "commit-hash") #f)) (branch-revisions - (branch-revisions-url 2 "master")))) + (branch-revisions-url %data-service-guix-repository-id + "master")))) (recent-processed-revision-commits (if (> (length processed-revision-commits) 5) diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm index c3ae256..7cb9cee 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -17,21 +17,17 @@ #:use-module (guix sets) #:use-module (guix memoization) #:use-module (guix build utils) - #:use-module ((guix build syscalls) - #:select (set-thread-name)) - #:use-module (guix-build-coordinator utils) - #:use-module (guix-build-coordinator utils fibers) #:use-module ((guix build download) #:select (http-fetch)) #:use-module ((guix build utils) #:select (with-directory-excursion)) + #:use-module (knots thread-pool) #:use-module (guix-qa-frontpage mumi) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage patchwork) + #:use-module (guix-qa-frontpage branch) #:use-module (guix-qa-frontpage guix-data-service) #:export (create-branch-for-issue - patchwork-series->branch - start-manage-patch-branches-thread get-issue-branch-base-and-target-refs)) @@ -129,65 +125,8 @@ (close-pipe pipe) result)) -(define (parse-patch-name name) - (let ((args - (and - (string-prefix? "[" name) - (let ((stop (string-index name #\]))) - (substring name 1 stop)))) - (as-bug-number - (lambda (arg) - (and (string-prefix? "bug#" arg) - (string->number (substring arg (string-length "bug#")))))) - (as-v2 - (lambda (arg) - (and (string-prefix? "v" arg) - (string->number (substring arg 1))))) - (as-patch-number - (lambda (arg) - (match (string-split arg #\/) - (((= string->number index) (= string->number total)) - (and index total (<= index total) - (cons index total))) - (else #f))))) - (let analyze ((bug-number #f) - (branch "master") - (version 1) - (index 1) - (total 1) - (arguments - (if args - (string-split args #\,) - '()))) - (match arguments - ((or ("") ()) - `((bug-number . ,bug-number) - (branch . ,branch) - (version . ,version) - (index . ,index) - (total . ,total))) - (((= as-bug-number (? number? new-bug-number)) - arguments ...) - (analyze new-bug-number branch version index total arguments)) - (((= as-v2 (? number? new-version)) - arguments ...) - (analyze bug-number branch new-version index total arguments)) - (((= as-patch-number ((? number? new-index) . (? number? new-total))) - arguments ...) - (analyze bug-number branch version new-index new-total arguments)) - ((feature-branch arguments ...) - (analyze bug-number feature-branch version index total arguments)))))) - -(define (patchwork-series->branch series) - (match (assoc-ref series "patches") - (#() "master") - (#(first-patch rest ...) - (let ((details - (parse-patch-name - (assoc-ref first-patch "name")))) - (assq-ref details 'branch))))) - -(define (create-branch-for-issue database issue-number patchwork-series) +(define (create-branch-for-issue database latest-processed-master-revision + issue-number patchwork-series) (define branch-name (simple-format #f "issue-~A" issue-number)) @@ -196,10 +135,9 @@ (define (get-base-commit) (let ((branch - (patchwork-series->branch patchwork-series))) + (assq-ref patchwork-series 'branch))) (if (string=? branch "master") - (get-latest-processed-branch-revision "master") - + latest-processed-master-revision (with-bare-git-repository (lambda () (invoke "git" "fetch" "--prune" "origin") @@ -226,14 +164,16 @@ 'issue-patches-overall-status #:args (list issue-number))) - (define (insert-log results) + (define (insert-log base-commit-hash results) (define log - (string-join - (map - (lambda (patch) - (assq-ref patch 'output)) - results) - "\n\n")) + (string-append + "Using base commit " base-commit-hash "\n\n" + (string-join + (map + (lambda (patch) + (assq-ref patch 'output)) + results) + "\n\n"))) (insert-create-branch-for-issue-log database issue-number log)) @@ -253,7 +193,7 @@ (results '())) (if (null? patch-data) (begin - (insert-log results) + (insert-log base-commit-hash results) (if (string=? base-commit-hash (with-repository (getcwd) repository @@ -304,7 +244,8 @@ (begin (simple-format #t "Failed to apply \"~A.patch\" (~A)\n" id name) - (insert-log new-results) + (insert-log base-commit-hash + new-results) #f))))))))) (delete-create-branch-for-issue-log database issue-number) @@ -385,7 +326,12 @@ #:args `(#:count ,(+ series-count series-count-buffer)) #:ttl 120)) (get-latest-processed-branch-revision* - (memoize get-latest-processed-branch-revision))) + (memoize get-latest-processed-branch-revision)) + (branches + (map (lambda (branch) + (assoc-ref branch "name")) + (list-branches + (list-branches-url %data-service-guix-repository-id))))) ;; Several series can use the same base revision, so memoize looking up ;; the changes compared to master @@ -404,6 +350,7 @@ (simple-format #t "checking for branches to delete (looking at ~A branches)\n" (length issue-numbers)) + (simple-format #t "all branches: ~A\n" branches) (for-each (lambda (issue-number) (when (or (if (not (mumi-issue-open? issue-number)) @@ -424,8 +371,9 @@ (assq-ref (get-issue-branch-base-and-target-refs issue-number) 'base)) - (branch (patchwork-series->branch - (assq-ref all-patchwork-series issue-number)))) + (branch + (assq-ref (assq-ref all-patchwork-series issue-number) + 'branch))) (with-exception-handler (lambda (exn) (if (and (guix-data-service-error? exn) @@ -435,7 +383,11 @@ "query_parameters" "base_commit" "message") (lambda (message) - (string=? message "unknown commit")))) + (string=? message "unknown commit"))) + ;; Don't treat the base revision + ;; as gone if the branch is + ;; unknown + (member branch branches)) (begin (simple-format (current-error-port) @@ -494,7 +446,9 @@ 'latest-patchwork-series-by-issue latest-patchwork-series-by-issue #:args `(#:count ,series-count) - #:ttl 120))) + #:ttl 120)) + (latest-processed-master-revision + (get-latest-processed-branch-revision "master"))) (for-each (match-lambda ((issue-number . patchwork-series) @@ -537,6 +491,7 @@ (const #t) (lambda () (create-branch-for-issue database + latest-processed-master-revision issue-number patchwork-series)) #:unwind? #t)))) @@ -564,7 +519,7 @@ (current-error-port) "exception in manage patch branches thread: ~A\n" exn) - (unless (worker-thread-timeout-error? exn) + (unless (thread-pool-timeout-error? exn) (sleep 240))) (lambda () (with-throw-handler #t diff --git a/guix-qa-frontpage/mumi.scm b/guix-qa-frontpage/mumi.scm index 6baa199..80f3646 100644 --- a/guix-qa-frontpage/mumi.scm +++ b/guix-qa-frontpage/mumi.scm @@ -18,6 +18,7 @@ (define-module (guix-qa-frontpage mumi) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (json) #:use-module (kolam http) @@ -33,6 +34,75 @@ mumi-bulk-issues)) +(define (at-most max-length lst) + "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise +return its MAX-LENGTH first elements and its tail." + (let loop ((len 0) + (lst lst) + (result '())) + (match lst + (() + (values (reverse result) '())) + ((head . tail) + (if (>= len max-length) + (values (reverse result) lst) + (loop (+ 1 len) tail (cons head result))))))) + +(define %max-cached-connections + ;; Maximum number of connections kept in cache by + ;; 'open-connection-for-uri/cached'. + 16) + +(define open-socket-for-uri/cached + (let ((cache '())) + (lambda* (uri #:key fresh? verify-certificate?) + "Return a connection for URI, possibly reusing a cached connection. +When FRESH? is true, delete any cached connections for URI and open a new one. +Return #f if URI's scheme is 'file' or #f. + +When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." + (define host (uri-host uri)) + (define scheme (uri-scheme uri)) + (define key (list host scheme (uri-port uri))) + + (and (not (memq scheme '(file #f))) + (match (assoc-ref cache key) + (#f + ;; Open a new connection to URI and evict old entries from + ;; CACHE, if any. + (let ((socket + (open-socket-for-uri + uri + #:verify-certificate? verify-certificate?)) + (new-cache evicted + (at-most (- %max-cached-connections 1) cache))) + (for-each (match-lambda + ((_ . port) + (false-if-exception (close-port port)))) + evicted) + (set! cache (alist-cons key socket new-cache)) + socket)) + (socket + (if (or fresh? (port-closed? socket)) + (begin + (false-if-exception (close-port socket)) + (set! cache (alist-delete key cache)) + (open-socket-for-uri/cached uri + #:verify-certificate? + verify-certificate?)) + (begin + ;; Drain input left from the previous use. + (drain-input socket) + socket)))))))) + +(define (call-with-cached-connection uri proc) + (let ((port (open-socket-for-uri/cached uri))) + (with-throw-handler #t + (lambda () + (proc port)) + (lambda _ + (close-port port))))) + (define* (graphql-http-get* uri document #:key (verify-certificate? #t) @@ -43,37 +113,31 @@ (variables '())) (call-with-values (lambda () - (http-get - (string-append uri - "?query=" - (uri-encode (scm->graphql-string document)) - "&" - "variables=" - (uri-encode (scm->json-string - ((@@ (kolam http) variables->alist) - variables)))) - #:streaming? #t - #:keep-alive? keep-alive? - #:verify-certificate? verify-certificate? - #:port port)) + (let ((response + body + (http-get + (string-append uri + "?query=" + (uri-encode (scm->graphql-string document)) + "&" + "variables=" + (uri-encode (scm->json-string + ((@@ (kolam http) variables->alist) + variables)))) + #:streaming? #t + #:keep-alive? keep-alive? + #:verify-certificate? verify-certificate? + #:port port))) + (values response + body))) (@@ (kolam http) graphql-http-response))) - (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 @@ -89,17 +153,14 @@ (let ((number-to-data (make-hash-table))) - (let loop ((chunks (chunk! (list-copy numbers) - 30)) - (port - (open-socket-for-uri - (string->uri url) - #:verify-certificate? #t))) - (if (null? chunks) - (close-port port) - (let ((response - (retry-on-error - (lambda () + (for-each + (lambda (chunk) + (let ((response + (retry-on-error + (lambda () + (call-with-cached-connection + (string->uri url) + (lambda (port) (graphql-http-get* url `(document @@ -107,30 +168,29 @@ `(query (#(issue #:number ,number) number title open severity tags (merged_with number)))) - (car chunks))) + chunk)) #:keep-alive? #t - #:port port)) - #:times 1 - #:delay 0))) - - (for-each - (lambda (res) - (let ((data (cdr res))) - (hash-set! number-to-data - (assoc-ref data "number") - `((title . ,(assoc-ref data "title")) - (open? . ,(assoc-ref data "open")) - (tags . ,(vector->list - (assoc-ref data "tags"))) - (merged-with . ,(map - (lambda (data) - (assoc-ref data "number")) - (vector->list - (assoc-ref data "merged_with")))) - (severity . ,(assoc-ref data "severity")))))) - response) - - (loop (cdr chunks) port)))) + #:port port)))) + #:times 1 + #:delay 0))) + + (for-each + (lambda (res) + (let ((data (cdr res))) + (hash-set! number-to-data + (assoc-ref data "number") + `((title . ,(assoc-ref data "title")) + (open? . ,(assoc-ref data "open")) + (tags . ,(vector->list + (assoc-ref data "tags"))) + (merged-with . ,(map + (lambda (data) + (assoc-ref data "number")) + (vector->list + (assoc-ref data "merged_with")))) + (severity . ,(assoc-ref data "severity")))))) + response))) + (chunk! (list-copy numbers) 30)) (map (lambda (number) (hash-ref number-to-data number)) diff --git a/guix-qa-frontpage/patchwork.scm b/guix-qa-frontpage/patchwork.scm index 8f9d570..e1ee24f 100644 --- a/guix-qa-frontpage/patchwork.scm +++ b/guix-qa-frontpage/patchwork.scm @@ -7,19 +7,27 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (json) + #:use-module (fibers) + #:use-module (knots non-blocking) + #:use-module (knots timeout) #:use-module (web uri) #:use-module (web client) #:use-module (web request) #:use-module (web response) + #:use-module (knots timeout) + #:use-module (knots non-blocking) #:use-module ((guix-build-coordinator utils) #:select (call-with-delay-logging)) #:use-module ((guix-build-coordinator utils fibers) #:select (retry-on-error)) #:use-module (guix-qa-frontpage mumi) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage debbugs) #:export (%patchwork-instance - latest-patchwork-series-by-issue)) + %patchwork-series-default-count + latest-patchwork-series-by-issue + latest-patchwork-series-for-issue)) (define %patchwork-instance (make-parameter "https://patches.guix-patches.cbaines.net")) @@ -77,12 +85,16 @@ (retry-on-error (lambda () (http-request uri - #:decode-body? #f)) + #:port (non-blocking-open-socket-for-uri uri) + #:decode-body? #f + #:streaming? #t)) #:times 2 #:delay 3))) (values - (json-string->scm (utf8->string body)) + (let ((json (json->scm body))) + (close-port body) + json) (and=> (assq-ref (response-headers response) 'link) (lambda (link-header) (and=> @@ -98,15 +110,95 @@ (assq-ref link-details 'uri) (uri-scheme uri)))))))))) +(define (parse-patch-name name) + (let ((args + (and + (string-prefix? "[" name) + (let ((stop (string-index name #\]))) + (substring name 1 stop)))) + (as-bug-number + (lambda (arg) + (and (string-prefix? "bug#" arg) + (string->number (substring arg (string-length "bug#")))))) + (as-v2 + (lambda (arg) + (and (string-prefix? "v" arg) + (string->number (substring arg 1))))) + (as-patch-number + (lambda (arg) + (match (string-split arg #\/) + (((= string->number index) (= string->number total)) + (and index total (<= index total) + (cons index total))) + (else #f))))) + (let analyze ((bug-number #f) + (branch "master") + (version 1) + (index 1) + (total 1) + (arguments + (if args + (string-split args #\,) + '()))) + (match arguments + ((or ("") ()) + `((bug-number . ,bug-number) + (branch . ,branch) + (version . ,version) + (index . ,index) + (total . ,total))) + (((= as-bug-number (? number? new-bug-number)) + arguments ...) + (analyze new-bug-number branch version index total arguments)) + (((= as-v2 (? number? new-version)) + arguments ...) + (analyze bug-number branch new-version index total arguments)) + (((= as-patch-number ((? number? new-index) . (? number? new-total))) + arguments ...) + (analyze bug-number branch version new-index new-total arguments)) + ((feature-branch arguments ...) + (analyze bug-number feature-branch version index total arguments)))))) + +(define parse-issue-title + (let ((regex (make-regexp "\\[([A-Z\\_a-z0-9\\-]+)\\].*"))) + (lambda (title) + (match (regexp-exec regex title) + (#f #f) + (m + (let ((branch (match:substring m 1))) + (if (string=? branch "PATCH") + #f + branch))))))) + +(define (patchwork-series->branch series) + (match (assoc-ref series "patches") + (#() "master") + (#(first-patch rest ...) + (let ((details + (parse-patch-name + (assoc-ref first-patch "name")))) + (assq-ref details 'branch))))) + +(define %patchwork-series-default-count + (make-parameter #f)) + (define* (latest-patchwork-series-by-issue #:key patchwork - count) + (count (%patchwork-series-default-count))) (define (string->issue-number str) (string->number (match:substring (string-match "\\[?bug#([0-9]*)(,|:|\\])" str) 1))) + (define (strip-title-prefix str) + (if (string-prefix? "[" str) + (let ((start (string-index str #\]))) + (if start + (string-drop str (+ 1 start)) + str)) + str)) + (define issue-number-to-series-hash-table (make-hash-table)) @@ -165,7 +257,10 @@ ;; Need more series, so keep going (let* ((series-batch next-page-uri - (request-patchwork-series patchwork-uri)) + (with-port-timeouts + (lambda () + (request-patchwork-series patchwork-uri)) + #:timeout 60)) (batch-hash-table (make-hash-table))) @@ -230,14 +325,21 @@ #t)) (assq-ref mumi 'merged-with))) (cons - `(,@data - (mumi . ,mumi)) + `(,issue-number + . + (("name" . ,(strip-title-prefix + (assq-ref mumi 'title))) + ,@(alist-delete "name" (cdr data) string=?) + (branch . ,(or (parse-issue-title + (assq-ref mumi 'title)) + (patchwork-series->branch data))) + (mumi . ,mumi))) result) result))) result series-by-issue-number mumi-data))))))) - - - +(define* (latest-patchwork-series-for-issue issue-number #:key patchwork) + (assq-ref (latest-patchwork-series-by-issue #:patchwork patchwork) + issue-number)) diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index ab0680a..4beaf09 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -32,18 +32,21 @@ #:use-module (fibers) #:use-module (fibers scheduler) #:use-module (fibers conditions) + #:use-module (knots) + #:use-module (knots web-server) + #:use-module (knots parallelism) #:use-module (guix store) + #:use-module (knots web-server) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module ((guix-data-service utils) + #:select (delete-duplicates/sort!)) #:use-module (guix-data-service web util) #:use-module ((guix-data-service web query-parameters) #: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)) + call-with-delay-logging)) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage reproducible-builds) @@ -53,6 +56,7 @@ #:use-module (guix-qa-frontpage branch) #:use-module (guix-qa-frontpage package) #:use-module (guix-qa-frontpage issue) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage manage-patch-branches) @@ -98,17 +102,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,26 +150,38 @@ (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)))) + (call-with-output-string + (lambda (port) + (write-metrics metrics-registry port) + (write-metrics plain-metrics-registry port))))) (('GET "branches") (let ((branches (with-sqlite-cache database - 'branches - (lambda () - (list-branches - (list-branches-url 2))) - #:ttl 60))) - (render-html - #:sxml - (branches-view branches)))) + 'list-non-master-branches + list-non-master-branches + #:ttl 300))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((branches . ,(list->vector + (map (match-lambda + ((name . details) + `((name . ,name) + ,@details))) + branches)))))) + (else + (render-html + #:sxml + (branches-view branches)))))) (('GET "branch" "master") (let ((substitute-availability systems-with-low-substitute-availability @@ -179,7 +198,7 @@ package-reproducibility)))) (('GET "branch" branch) (let ((revisions - derivation-changes + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master @@ -204,25 +223,33 @@ #:sxml (branch-view branch revisions - derivation-changes + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master master-branch-systems-with-low-substitute-availability)))) (('GET "branch" branch "package-changes") - (let ((revisions - derivation-changes - substitute-availability - package-reproducibility - up-to-date-with-master - (with-sqlite-cache - database - 'branch-data - branch-data - #:args - (list branch) - #:version 3 - #:ttl 6000))) + (let* ((revisions + derivation-changes-counts + substitute-availability + package-reproducibility + up-to-date-with-master + (with-sqlite-cache + database + 'branch-data + branch-data + #:args + (list branch) + #:version 3 + #:ttl 6000)) + (derivation-changes + (with-sqlite-cache + database + 'branch-derivation-changes-data + branch-derivation-changes-data/all-systems + #:args + (list revisions) + #:ttl 6000))) (render-html #:sxml (branch-package-changes-view branch @@ -257,16 +284,13 @@ symbol-key #f)))) query-params)) - (latest-series-branches - (map - (match-lambda - ((_ . series) - (patchwork-series->branch series))) - latest-series)) (branch-options - (sort (delete-duplicates - latest-series-branches) - string<?)) + (reverse + (delete-duplicates/sort! + (map (lambda (series) + (assq-ref series 'branch)) + latest-series) + string<?))) (filtered-branches (filter-map (match-lambda @@ -277,7 +301,7 @@ query-params)) (latest-series-with-overall-statuses (filter-map - (lambda (series branch) + (lambda (series) (let ((overall-status (with-sqlite-cache database @@ -285,7 +309,9 @@ (const 'unknown) #:store-computed-value? #f #:args (list (first series)) - #:ttl 3600))) + #:ttl 3600)) + (branch + (assq-ref series 'branch))) (if (and (or (null? filtered-statuses) (member overall-status filtered-statuses)) @@ -295,8 +321,7 @@ `((branch . ,branch) (overall-status . ,overall-status))) #f))) - latest-series - latest-series-branches)) + latest-series)) (sorted-latest-series (sort latest-series-with-overall-statuses @@ -590,13 +615,12 @@ </svg>")) port))))) (('GET "issue" number) - (let ((series (assq-ref (with-sqlite-cache - database - 'latest-patchwork-series-by-issue - latest-patchwork-series-by-issue - #:args `(#:count ,patch-issues-to-show) - #:ttl 1800) - (string->number number)))) + (let ((series (with-sqlite-cache + database + 'latest-patchwork-series-for-issue + latest-patchwork-series-for-issue + #:args (list (string->number number)) + #:ttl 1800))) (if series (let* ((base-and-target-refs derivation-changes @@ -616,8 +640,6 @@ (select-create-branch-for-issue-log database number)) - (branch - (patchwork-series->branch series)) (master-branch-substitute-availability systems-with-low-substitute-availability master-branch-package-reproducibility @@ -630,7 +652,7 @@ (render-html #:sxml (issue-view number series - branch + (assq-ref series 'branch) (assq-ref (assq-ref series 'mumi) 'tags) base-and-target-refs @@ -769,6 +791,13 @@ has no patches or has been closed.") (render-html #:sxml (package-view package-data)))) + (('GET "robots") ; robots.txt + (render-text + "User-agent: * +Disallow: /patches +Disallow: /issue +")) + (('GET "README") (let ((filename (string-append doc-dir "/README.html"))) (if (file-exists? filename) @@ -801,27 +830,23 @@ has no patches or has been closed.") (request-method request) (uri-path (request-uri request)))) - (call-with-error-handling - (lambda () - (let-values (((request-components mime-types) - (request->path-components-and-mime-type request))) - (call-with-delay-logging - controller - #:threshold 30 - #:args (list request - (cons (request-method request) - request-components) - mime-types - body)))) - #:on-error 'backtrace - #:post-error (lambda args - (render-html #:sxml (error-page args) - #:code 500)))) + (let ((request-components + mime-types + (request->path-components-and-mime-type request))) + (call-with-delay-logging + controller + #:threshold 30 + #:args (list request + (cons (request-method request) + request-components) + mime-types + body)))) (define* (start-guix-qa-frontpage port host assets-directory database metrics-registry #:key (controller-args '()) submit-builds? + manage-patch-branches? patch-issues-to-show generate-reproducible.json) (define controller @@ -831,6 +856,11 @@ has no patches or has been closed.") (when generate-reproducible.json (start-generate-reproducible.json-thread)) + (when manage-patch-branches? + (start-manage-patch-branches-thread database + metrics-registry + #:series-count patch-issues-to-show)) + (let ((finished? (make-condition))) (call-with-new-thread (lambda () @@ -841,14 +871,37 @@ has no patches or has been closed.") (run-fibers (lambda () + (start-refresh-patch-branches-data-fiber + database + metrics-registry + #:number-of-series-to-refresh patch-issues-to-show) + + (start-refresh-non-patch-branches-data-fiber database + metrics-registry) + (when submit-builds? - (start-submit-patch-builds-fiber database - "http://127.0.0.1:8746" - "https://data.qa.guix.gnu.org" - metrics-registry - #:series-count - patch-issues-to-show)) + (parameterize + ((%fiberized-submit-build + (fiberize (lambda args + (call-with-duration-metric + metrics-registry + "submit_build_duration_seconds" + (lambda () + (apply submit-build args)))) + #:parallelism 8))) + + (start-submit-patch-builds-fiber database + "http://127.0.0.1:8746" + "https://data.qa.guix.gnu.org" + metrics-registry + #:series-count + patch-issues-to-show) + (start-submit-branch-builds-fiber database + "http://127.0.0.1:8746" + "https://data.qa.guix.gnu.org" + metrics-registry))) (wait finished?)) + #:hz 0 #:parallelism 1))) (call-with-sigint @@ -871,12 +924,20 @@ has no patches or has been closed.") (iota (length schedulers)) schedulers)) - (run-server/patched - (lambda (request body) - (apply values (handler request body controller))) + (run-knots-web-server + (lambda (request) + (apply values (handler request + (read-request-body request) + controller))) + #:exception-handler + (lambda (exn) + (apply values + (render-html #:sxml (error-page exn) + #:code 500))) #:host host #:port port) (wait finished?)) - #:parallelism 2)) + #:hz 0 + #:parallelism 1)) finished?))) diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm index d96db57..63b741c 100644 --- a/guix-qa-frontpage/utils.scm +++ b/guix-qa-frontpage/utils.scm @@ -18,172 +18,55 @@ (define-module (guix-qa-frontpage utils) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (ice-9 q) - #:use-module (ice-9 iconv) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) - #:use-module (ice-9 format) #:use-module (ice-9 threads) - #:use-module (ice-9 atomic) - #:use-module (ice-9 textual-ports) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 exceptions) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 suspendable-ports) - #:use-module ((ice-9 ports internal) #:select (port-poll - port-read-wait-fd - port-write-wait-fd)) - #:use-module (web uri) - #:use-module (web http) - #:use-module (web client) - #:use-module (web request) - #:use-module (web response) #:use-module (fibers) - #:use-module (fibers timers) #:use-module (fibers channels) - #:use-module (fibers scheduler) - #:use-module (fibers conditions) - #:use-module (fibers operations) - #:export (port-read-timeout-error? - port-write-timeout-error? - with-fibers-port-timeouts)) - -(define (readable? port) - "Test if PORT is writable." - (match (select (vector port) #() #() 0) - ((#() #() #()) #f) - ((#(_) #() #()) #t))) - -(define (writable? port) - "Test if PORT is writable." - (match (select #() (vector port) #() 0) - ((#() #() #()) #f) - ((#() #(_) #()) #t))) - -(define (make-wait-operation ready? schedule-when-ready port port-ready-fd this-procedure) - (make-base-operation #f - (lambda _ - (and (ready? (port-ready-fd port)) values)) - (lambda (flag sched resume) - (define (commit) - (match (atomic-box-compare-and-swap! flag 'W 'S) - ('W (resume values)) - ('C (commit)) - ('S #f))) - (schedule-when-ready - sched (port-ready-fd port) commit)))) - -(define (wait-until-port-readable-operation port) - "Make an operation that will succeed when PORT is readable." - (unless (input-port? port) - (error "refusing to wait forever for input on non-input port")) - (make-wait-operation readable? schedule-task-when-fd-readable port - port-read-wait-fd - wait-until-port-readable-operation)) - -(define (wait-until-port-writable-operation port) - "Make an operation that will succeed when PORT is writable." - (unless (output-port? port) - (error "refusing to wait forever for output on non-output port")) - (make-wait-operation writable? schedule-task-when-fd-writable port - port-write-wait-fd - wait-until-port-writable-operation)) - - - -(define &port-timeout - (make-exception-type '&port-timeout - &external-error - '(port))) - -(define make-port-timeout-error - (record-constructor &port-timeout)) - -(define port-timeout-error? - (record-predicate &port-timeout)) - -(define &port-read-timeout - (make-exception-type '&port-read-timeout - &port-timeout - '())) - -(define make-port-read-timeout-error - (record-constructor &port-read-timeout)) - -(define port-read-timeout-error? - (record-predicate &port-read-timeout)) - -(define &port-write-timeout - (make-exception-type '&port-write-timeout - &port-timeout - '())) - -(define make-port-write-timeout-error - (record-constructor &port-write-timeout)) - -(define port-write-timeout-error? - (record-predicate &port-write-timeout)) - -(define* (with-fibers-port-timeouts thunk - #:key timeout - (read-timeout timeout) - (write-timeout timeout)) - (define (no-fibers-wait port mode timeout) - (define poll-timeout-ms 200) - - ;; When the GC runs, it restarts the poll syscall, but the timeout - ;; remains unchanged! When the timeout is longer than the time - ;; between the syscall restarting, I think this renders the - ;; timeout useless. Therefore, this code uses a short timeout, and - ;; repeatedly calls poll while watching the clock to see if it has - ;; timed out overall. - (let ((timeout-internal - (+ (get-internal-real-time) - (* internal-time-units-per-second - timeout)))) - (let loop ((poll-value - (port-poll port mode poll-timeout-ms))) - (if (= poll-value 0) - (if (> (get-internal-real-time) - timeout-internal) - (raise-exception - (if (string=? mode "r") - (make-port-read-timeout-error port) - (make-port-write-timeout-error port))) - (loop (port-poll port mode poll-timeout-ms))) - poll-value)))) - - (unless read-timeout - (if timeout - (error "unset read-timeout") - (error "unset timeout"))) - (unless write-timeout - (error "unset write-timeout")) - - (parameterize - ((current-read-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-readable-operation port) - (wrap-operation - (sleep-operation read-timeout) - (lambda () - (raise-exception - (make-port-read-timeout-error thunk port)))))) - (no-fibers-wait port "r" read-timeout)))) - (current-write-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-writable-operation port) - (wrap-operation - (sleep-operation write-timeout) - (lambda () - (raise-exception - (make-port-write-timeout-error thunk port)))))) - (no-fibers-wait port "w" write-timeout))))) - (thunk))) + #:use-module (knots) + #:use-module (zlib) + #:export (non-blocking + call-with-zlib-input-port*)) + +(define (non-blocking thunk) + (let ((channel (make-channel))) + (call-with-default-io-waiters + (lambda () + (call-with-new-thread + (lambda () + (with-exception-handler + (lambda (exn) + (put-message channel `(exception ,exn))) + (lambda () + (with-throw-handler #t + (lambda () + (call-with-values thunk + (lambda values + (put-message channel `(values ,@values))))) + (lambda args + (display (backtrace) (current-error-port)) + (newline (current-error-port))))) + #:unwind? #t))))) + (match (get-message channel) + (('values . results) + (apply values results)) + (('exception . exn) + (raise-exception exn))))) + +(define* (call-with-zlib-input-port* port proc + #:key + (format 'zlib) + (buffer-size %default-buffer-size)) + "Call PROC with a port that wraps PORT and decompresses data read from it. +PORT is closed upon completion. The zlib internal buffer size is set to +BUFFER-SIZE bytes." + (let ((zlib (make-zlib-input-port port + #:format format + #:buffer-size buffer-size + #:close? #t))) + (call-with-values + (lambda () + (proc zlib)) + (lambda vals + (close-port zlib) + (apply values vals))))) diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm index 5c7c94f..d7c93f7 100644 --- a/guix-qa-frontpage/view/branch.scm +++ b/guix-qa-frontpage/view/branch.scm @@ -5,6 +5,7 @@ #:use-module (ice-9 format) #:use-module ((guix-data-service model utils) #:select (group-to-alist)) #:use-module (guix-qa-frontpage manage-builds) + #:use-module (guix-qa-frontpage guix-data-service) #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage view util) #:use-module (guix-qa-frontpage view shared) @@ -13,16 +14,11 @@ master-branch-view)) -(define (branch-view branch revisions derivation-changes +(define (branch-view branch revisions derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master master-branch-systems-with-low-substitute-availability) - (define derivation-changes-counts - (if (assq-ref derivation-changes 'exception) - derivation-changes - (assq-ref derivation-changes 'counts))) - (layout #:title (simple-format #f "Branch ~A" branch) #:head @@ -58,7 +54,9 @@ td.bad { "View Git branch")) (li (a (@ (href ,(simple-format - #f "https://data.qa.guix.gnu.org/repository/2/branch/~A" + #f "~A/repository/~A/branch/~A" + %data-service-url-base + %data-service-guix-repository-id branch))) "View branch with Guix Data Service")))) diff --git a/guix-qa-frontpage/view/branches.scm b/guix-qa-frontpage/view/branches.scm index 90d1da7..9573d2b 100644 --- a/guix-qa-frontpage/view/branches.scm +++ b/guix-qa-frontpage/view/branches.scm @@ -10,10 +10,22 @@ #:body `((main (table + (thead + (tr (th "Branch") + (th "Request to merge"))) (tbody - ,@(map (lambda (branch-details) - (let ((name (assoc-ref branch-details "name"))) - `(tr - (td (a (@ (href ,(simple-format #f "/branch/~A" name))) - ,name))))) + ,@(map (match-lambda + ((name . details) + (let ((issue-number + (assoc-ref details "issue_number"))) + `(tr + (td (a (@ (href ,(simple-format #f "/branch/~A" name)) + (style "font-family: monospace;")) + ,name)) + (td ,@(if issue-number + `((a (@ (href ,(string-append + "https://issues.guix.gnu.org/" + (number->string issue-number)))) + "#" ,issue-number)) + '())))))) branches))))))) 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/issue.scm b/guix-qa-frontpage/view/issue.scm index 4e851f8..567ba24 100644 --- a/guix-qa-frontpage/view/issue.scm +++ b/guix-qa-frontpage/view/issue.scm @@ -78,7 +78,7 @@ (simple-format #f "~A/log/?h=~A&qt=range&q=~A..~A" - "https://git.guix-patches.cbaines.net/guix-patches" + "https://git.qa.guix.gnu.org/guix-patches" branch-name base-tag branch-name)))) "View Git branch"))) '()) @@ -258,7 +258,10 @@ patches to record a review, which will highlight that these patches should be ready to merge.") - (p "Here's a list of common things to check, tick them off as you review + (p "There's some " + (a (@ (href "https://guix.gnu.org/manual/devel/en/html_node/Reviewing-the-Work-of-Others.html")) + "guidance in the manual about reviewing patches") + ". Here's a list of common things to check, tick them off as you review the patches:")) ,@(map @@ -475,5 +478,5 @@ Guix QA review form submission:" (uri-encode email-text)))) (b "Open mail client to send review email")) (p "If the above link doesn't work for you, the contents of the suggested email is given below, and can be sent " - (strong "to control@debbugs.gnu.org and 66195@debbugs.gnu.org")) + (strong "to control@debbugs.gnu.org and " ,issue-number "@debbugs.gnu.org")) (pre ,email-text))))) diff --git a/guix-qa-frontpage/view/patches.scm b/guix-qa-frontpage/view/patches.scm index fc5c575..dc0af45 100644 --- a/guix-qa-frontpage/view/patches.scm +++ b/guix-qa-frontpage/view/patches.scm @@ -127,47 +127,11 @@ 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;")) + ,@(let ((branch (assq-ref details 'branch))) + (if (string=? branch "master") + '() + `((code ,branch)))) ,(assoc-ref details "name")))))) latest-series))))))) diff --git a/guix-qa-frontpage/view/shared.scm b/guix-qa-frontpage/view/shared.scm index 708ac63..804923b 100644 --- a/guix-qa-frontpage/view/shared.scm +++ b/guix-qa-frontpage/view/shared.scm @@ -745,55 +745,64 @@ (td (@ (colspan 10) (class "bad")) "Comparison unavailable" - ,@(or (and=> - (assq-ref derivation-changes-counts - 'invalid_query_parameters) - (lambda (params) - (append-map - (match-lambda - ((param . details) - (let ((error - (assq-ref details 'error))) - (cond - ((member param '("base_commit" - "target_commit")) - `((br) - (a - (@ (href - ,(string-append - "https://data.qa.guix.gnu.org" - "/revision/" - (assq-ref - revisions - (if (string=? param "base_commit") - 'base - 'target))))) - ,(cond - ((eq? error 'unknown-commit) - (string-append - (if (string=? param "base_commit") - "Base revision " - "Target revision ") - "unknown to the data service.")) - ((member error - '(yet-to-process-revision - failed-to-process-revision)) - (simple-format - #f "~A to process ~A" - (if (eq? error 'yet-to-process-revision) - "Yet" - "Failed") - (if (string=? param "base_commit") - "base revision (from master branch)" - "target revision"))) - (else - (string-append - "Error with " - (if (string=? param "base_commit") - "base revision." - "target revision."))))))))))) - params))) - '())))))))) + ,@(cond + ((eq? (assq-ref derivation-changes-counts 'exception) + 'guix-data-service-invalid-parameters) + (append-map + (match-lambda + ((param . details) + (let ((error + (assq-ref details 'error))) + (cond + ((member param '("base_commit" + "target_commit")) + `((br) + (a + (@ (href + ,(string-append + "https://data.qa.guix.gnu.org" + "/revision/" + (assq-ref + revisions + (if (string=? param "base_commit") + 'base + 'target))))) + ,(cond + ((eq? error 'unknown-commit) + (string-append + (if (string=? param "base_commit") + "Base revision " + "Target revision ") + "unknown to the data service.")) + ((member error + '(yet-to-process-revision + failed-to-process-revision)) + (simple-format + #f "~A to process ~A" + (if (eq? error 'yet-to-process-revision) + "Yet" + "Failed") + (if (string=? param "base_commit") + "base revision (from master branch)" + "target revision"))) + (else + (string-append + "Error with " + (if (string=? param "base_commit") + "base revision." + "target revision."))))))))))) + (assq-ref derivation-changes-counts + 'invalid_query_parameters))) + ((eq? (assq-ref derivation-changes-counts 'exception) + 'guix-data-service-exception) + (let ((url + (assq-ref derivation-changes-counts 'url))) + `((br) + "Exception fetching data from " + (a (@ (href ,url)) + ,url)))) + (else + '()))))))))) (define (package-cross-changes-summary-table revisions cross-derivation-changes-counts diff --git a/guix-qa-frontpage/view/util.scm b/guix-qa-frontpage/view/util.scm index 60ec66a..497e718 100644 --- a/guix-qa-frontpage/view/util.scm +++ b/guix-qa-frontpage/view/util.scm @@ -45,6 +45,8 @@ table/branches-with-most-recent-commits render-html + render-json + render-text general-not-found error-page @@ -417,6 +419,12 @@ main > header { (define render-html guix-data-service:render-html) +(define render-json + guix-data-service:render-json) + +(define render-text + guix-data-service:render-text) + (define (general-not-found header-text body) (layout #:body @@ -424,17 +432,14 @@ main > header { (h1 ,header-text) (p ,body))))) -(define* (error-page #:optional error) +(define* (error-page #:optional exn) (layout #:body `((main (h1 "An error occurred") (p "Sorry about that!") - ,@(if error - (match error - ((key . args) - `((b ,key) - (pre ,args)))) + ,@(if exn + `((pre ,exn)) '()))))) (define file-mime-types |