diff options
| -rw-r--r-- | guix-dev.scm | 1 | ||||
| -rw-r--r-- | guix-qa-frontpage/branch.scm | 106 | ||||
| -rw-r--r-- | guix-qa-frontpage/database.scm | 107 | ||||
| -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 | 139 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 412 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 54 | ||||
| -rw-r--r-- | guix-qa-frontpage/mumi.scm | 165 | ||||
| -rw-r--r-- | guix-qa-frontpage/patchwork.scm | 38 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 171 | ||||
| -rw-r--r-- | guix-qa-frontpage/utils.scm | 164 | ||||
| -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/issue.scm | 9 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/shared.scm | 107 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/util.scm | 17 | ||||
| -rw-r--r-- | qa-information-flow.plantuml | 13 | ||||
| -rw-r--r-- | scripts/guix-qa-frontpage.in | 9 |
21 files changed, 1136 insertions, 838 deletions
diff --git a/guix-dev.scm b/guix-dev.scm index e820570..595be5a 100644 --- a/guix-dev.scm +++ b/guix-dev.scm @@ -52,6 +52,7 @@ guix-data-service guile-json-4 guile-fibers-1.1 + guile-knots guile-kolam guile-git guile-debbugs diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm index 719b350..6276476 100644 --- a/guix-qa-frontpage/branch.scm +++ b/guix-qa-frontpage/branch.scm @@ -23,12 +23,16 @@ #: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) @@ -38,6 +42,8 @@ #: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 @@ -63,11 +69,12 @@ `(("issue_number" . ,issue-number) ("issue_date" . ,(assoc-ref issue "date")) ("blocked_by" - . ,(map (lambda (issue) - (assoc-ref issue "number")) - (or (and=> (assoc-ref issue "blocked_by") - vector->list) - '())))))))) + . ,(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 @@ -98,10 +105,11 @@ "master") (string-prefix? "version-" (assoc-ref branch "name")) + (string-prefix? "wip-" + (assoc-ref branch "name")) (string=? (assoc-ref branch "commit") ""))) - (list-branches - (list-branches-url 2)))))) + (get-git-remote-branches "origin"))))) (let* ((initial-ordered-branches (stable-sort branches @@ -145,9 +153,11 @@ (assq-ref initial-ordering-index-by-branch (car b))) (a-blocked-by - (or (assoc-ref (cdr a) "blocked_by") '())) + (vector->list + (or (assoc-ref (cdr a) "blocked_by") #()))) (b-blocked-by - (or (assoc-ref (cdr b) "blocked_by") '()))) + (vector->list + (or (assoc-ref (cdr b) "blocked_by") #())))) (< (if (null? a-blocked-by) a-initial-ordering-index @@ -182,6 +192,26 @@ (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 (get-commit @@ -217,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 @@ -250,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?)) @@ -260,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 @@ -303,10 +337,12 @@ (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")))) @@ -379,7 +415,7 @@ (string-prefix? "version-" (assoc-ref branch "name")))) (list-branches - (list-branches-url 2)))) + (list-branches-url %data-service-guix-repository-id)))) #:ttl 0))) (for-each diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm index c44d83a..06ce3bd 100644 --- a/guix-qa-frontpage/database.scm +++ b/guix-qa-frontpage/database.scm @@ -28,16 +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 - make-queueing-channel)) + #:select (retry-on-error)) #:use-module (guix-qa-frontpage guix-data-service) #:export (setup-database @@ -58,14 +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 - set-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)) @@ -145,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 @@ -182,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 @@ -220,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) @@ -246,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 @@ -258,10 +261,11 @@ PRAGMA optimize;"))) (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-channel! + (set-database-writer-thread-set-channel! database - (make-queueing-channel - (database-writer-thread-channel database))) + (spawn-queueing-fiber + (thread-pool-channel + (database-writer-thread-set database)))) (spawn-fiber (lambda () @@ -322,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))) @@ -346,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)))) @@ -430,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 @@ -464,12 +472,17 @@ 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) @@ -557,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 @@ -613,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 94267a5..beed41f 100644 --- a/guix-qa-frontpage/issue.scm +++ b/guix-qa-frontpage/issue.scm @@ -23,10 +23,12 @@ #: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) @@ -179,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 @@ -290,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 @@ -310,7 +308,20 @@ 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) @@ -328,6 +339,17 @@ (take latest-series number-of-series-to-refresh) latest-series))) + (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) + (non-blocking (lambda () (update-repository!))) @@ -351,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 @@ -388,7 +403,7 @@ #:args (list issue-number) #:ttl 0))) #:unwind? #t))) - 5 + 50 series-to-refresh))) (spawn-fiber diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index d07a773..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) @@ -45,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")) @@ -89,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 @@ -210,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 @@ -240,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 @@ -263,106 +281,105 @@ (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))) - (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) - (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))) - (submit-builds-for-category build-coordinator - guix-data-service - 'branch - branch - derivations-and-priorities - (set) - branch-commit))))) - (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) @@ -426,7 +443,9 @@ ((name . details) (->bool (assoc-ref details "issue_number")))) all-branches) - 2)) + ;; TODO The builds for the first branch should be mostly + ;; complete before submitting builds for any others + 1)) (branch-names (map car branches))) @@ -464,7 +483,7 @@ (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 @@ -482,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 @@ -497,7 +517,9 @@ #t #t #t - tags)) + tags + #:skip-updating-derived-priorities? + skip-updating-derived-priorities?)) #:timeout 240))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) @@ -534,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 @@ -596,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 @@ -626,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 @@ -655,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 @@ -729,7 +783,8 @@ build-ids-to-keep-set target-commit #:key build-limit - (build-count-priority-penalty (const 0))) + (build-count-priority-penalty (const 0)) + skip-updating-derived-priorities?) (define (submit-builds build-details build-ids-to-keep-set) (define submit-build/fiberized @@ -748,7 +803,9 @@ ((key . ,category-name) (value . ,category-value)) ((key . revision) - (value . ,target-commit))))))) + (value . ,target-commit))) + #:skip-updating-derived-priorities? + skip-updating-derived-priorities?)))) (fibers-for-each submit-single build-details)) @@ -833,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 16bfbd9..7cb9cee 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -17,16 +17,14 @@ #: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 @@ -127,7 +125,8 @@ (close-pipe pipe) result)) -(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)) @@ -138,8 +137,7 @@ (let ((branch (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") @@ -166,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)) @@ -193,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 @@ -244,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) @@ -325,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 @@ -344,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)) @@ -376,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) @@ -435,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) @@ -478,6 +491,7 @@ (const #t) (lambda () (create-branch-for-issue database + latest-processed-master-revision issue-number patchwork-series)) #:unwind? #t)))) @@ -505,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 94c1842..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,22 +113,25 @@ (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) (let ((response (graphql-http-get "https://issues.guix.gnu.org/graphql" @@ -80,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 @@ -98,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 049012f..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=> @@ -167,9 +179,12 @@ (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 @@ -179,7 +194,9 @@ (define (strip-title-prefix str) (if (string-prefix? "[" str) (let ((start (string-index str #\]))) - (string-drop str (+ 1 start))) + (if start + (string-drop str (+ 1 start)) + str)) str)) (define issue-number-to-series-hash-table @@ -240,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))) @@ -320,6 +340,6 @@ 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 ccfa985..4beaf09 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -32,7 +32,11 @@ #: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) @@ -42,9 +46,7 @@ #:select (parse-query-string)) #:use-module ((guix-build-coordinator utils) #:select (with-time-logging - 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) @@ -162,14 +164,24 @@ (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 @@ -186,7 +198,7 @@ package-reproducibility)))) (('GET "branch" branch) (let ((revisions - derivation-changes + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master @@ -211,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 @@ -595,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 @@ -772,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) @@ -804,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 @@ -834,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 () @@ -844,9 +871,6 @@ has no patches or has been closed.") (run-fibers (lambda () - (%fiberized-submit-build - (fiberize submit-build #:parallelism 8)) - (start-refresh-patch-branches-data-fiber database metrics-registry @@ -856,16 +880,26 @@ has no patches or has been closed.") 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) - (start-submit-branch-builds-fiber database - "http://127.0.0.1:8746" - "https://data.qa.guix.gnu.org" - metrics-registry)) + (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))) @@ -890,9 +924,16 @@ 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) diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm index f0b47a9..63b741c 100644 --- a/guix-qa-frontpage/utils.scm +++ b/guix-qa-frontpage/utils.scm @@ -23,138 +23,50 @@ #:use-module (ice-9 threads) #:use-module (fibers) #:use-module (fibers channels) - #:use-module ((guix-build-coordinator utils) #:select (with-port-timeouts)) - #:use-module (guix-build-coordinator utils fibers) - #:export (fiberize - fibers-map - fibers-batch-for-each - fibers-for-each - non-blocking) - #:re-export (with-fibers-port-timeouts)) - -(define* (fiberize proc #:key (parallelism 1)) - (let ((channel (make-channel))) - (for-each - (lambda _ - (spawn-fiber - (lambda () - (while #t - (let ((reply-channel args (car+cdr - (get-message channel)))) - (put-message - reply-channel - (with-exception-handler - (lambda (exn) - (cons 'exception exn)) - (lambda () - (with-throw-handler #t - (lambda () - (call-with-values - (lambda () - (apply proc args)) - (lambda vals - (cons 'result vals)))) - (lambda _ - (backtrace)))) - #:unwind? #t))))) - #:parallel? #t)) - (iota parallelism)) - - (lambda args - (let ((reply-channel (make-channel))) - (put-message channel (cons reply-channel args)) - (match (get-message reply-channel) - (('result . vals) (apply values vals)) - (('exception . exn) (raise-exception exn))))))) - -(define (fibers-map proc . lists) - (let ((channels - (apply - map - (lambda args - (let ((channel (make-channel))) - (spawn-fiber - (lambda () - (put-message - channel - (with-exception-handler - (lambda (exn) - (cons 'exception exn)) - (lambda () - (with-throw-handler #t - (lambda () - (call-with-values - (lambda () - (apply proc args)) - (lambda val - (cons 'result val)))) - (lambda _ - (backtrace)))) - #:unwind? #t)))) - channel)) - lists))) - (map - (match-lambda - (('result . val) val) - (('exception . exn) (raise-exception exn))) - (map get-message channels)))) - -(define (fibers-batch-for-each proc batch-size . lists) - ;; Like split-at, but don't care about the order of the resulting lists, and - ;; don't error if the list is shorter than i elements - (define (split-at* lst i) - (let lp ((l lst) (n i) (acc '())) - (if (or (<= n 0) (null? l)) - (values (reverse! acc) l) - (lp (cdr l) (- n 1) (cons (car l) acc))))) - - ;; As this can be called with lists with tens of thousands of items in them, - ;; batch the - (define (get-batch lists) - (let ((split-lists - (map (lambda (lst) - (let ((batch rest (split-at* lst batch-size))) - (cons batch rest))) - lists))) - (values (map car split-lists) - (map cdr split-lists)))) - - (let loop ((lists lists)) - (call-with-values - (lambda () - (get-batch lists)) - (lambda (batch rest) - (apply fibers-map proc batch) - (unless (null? (car rest)) - (loop rest))))) - *unspecified*) - -(define (fibers-for-each proc . lists) - (apply fibers-batch-for-each proc 20 lists)) + #:use-module (knots) + #:use-module (zlib) + #:export (non-blocking + call-with-zlib-input-port*)) (define (non-blocking thunk) (let ((channel (make-channel))) - (call-with-new-thread + (call-with-default-io-waiters (lambda () - (with-exception-handler - (lambda (exn) - (put-message channel `(exception ,exn))) - (lambda () - (with-throw-handler #t - (lambda () - (call-with-values - (lambda () - ;; This is mostly to set non fibers IO waiters - (with-port-timeouts thunk - #:timeout (* 300 1000))) - (lambda values - (put-message channel `(values ,@values))))) - (lambda args - (display (backtrace) (current-error-port)) - (newline (current-error-port))))) - #:unwind? #t))) + (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/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/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 diff --git a/qa-information-flow.plantuml b/qa-information-flow.plantuml index 5257b80..cd9f196 100644 --- a/qa-information-flow.plantuml +++ b/qa-information-flow.plantuml @@ -1,14 +1,13 @@ @startuml -cloud "Running on beid" { +cloud "Running on mago" { component Patchwork [ Patchwork patches.guix-patches.cbaines.net ] - component patchesgit [ - Patches Git repository - git.guix-patches.cbaines.net - ] +} + +cloud "Running on hydra-guix-130" { component dataservice [ Guix Data Service data.qa.guix.gnu.org @@ -16,6 +15,10 @@ cloud "Running on beid" { } cloud "Running on bayfront" { + component patchesgit [ + Patches Git repository + git.qa.guix.gnu.org + ] component qafrontpage [ QA Frontpage qa.guix.gnu.org diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in index eee3b4c..c666901 100644 --- a/scripts/guix-qa-frontpage.in +++ b/scripts/guix-qa-frontpage.in @@ -267,7 +267,8 @@ (with-fluids ((%file-port-name-canonicalization 'none)) (parameterize - ((%git-repository-location (string-append (getcwd) "/guix.git"))) + ((%git-repository-location (string-append (getcwd) "/guix.git")) + (%patchwork-series-default-count patch-issues-to-show)) (let* ((metrics-registry (make-metrics-registry #:namespace "guixqafrontpage")) @@ -275,11 +276,6 @@ (setup-database (assq-ref opts 'database) metrics-registry))) - (when (assq-ref opts 'manage-patch-branches) - (start-manage-patch-branches-thread database - metrics-registry - #:series-count patch-issues-to-show)) - (start-guix-qa-frontpage (assq-ref opts 'port) (assq-ref opts 'host) @@ -289,5 +285,6 @@ #:controller-args `(#:doc-dir ,doc-dir #:patch-issues-to-show ,patch-issues-to-show) #:submit-builds? (assq-ref opts 'submit-builds) + #:manage-patch-branches? (assq-ref opts 'manage-patch-branches) #:patch-issues-to-show patch-issues-to-show #:generate-reproducible.json #t))))))) |