diff options
| -rw-r--r-- | guix-qa-frontpage/branch.scm | 43 | ||||
| -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/guix-data-service.scm | 212 | ||||
| -rw-r--r-- | guix-qa-frontpage/issue.scm | 135 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 361 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 32 | ||||
| -rw-r--r-- | guix-qa-frontpage/patchwork.scm | 29 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 23 | ||||
| -rw-r--r-- | guix-qa-frontpage/utils.scm | 28 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/branch.scm | 7 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/issue.scm | 2 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/shared.scm | 107 | ||||
| -rw-r--r-- | scripts/guix-qa-frontpage.in | 9 |
14 files changed, 615 insertions, 490 deletions
diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm index 719b350..b372992 100644 --- a/guix-qa-frontpage/branch.scm +++ b/guix-qa-frontpage/branch.scm @@ -26,6 +26,8 @@ #: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) @@ -38,6 +40,7 @@ #:use-module (guix-qa-frontpage manage-builds) #:export (list-non-master-branches + branch-derivation-changes-data branch-data master-branch-data @@ -182,6 +185,16 @@ (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-data branch-name) (define branch-commit (get-commit @@ -217,24 +230,16 @@ #: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) + (derivation-changes-counts + (retry-on-error + (lambda () + (branch-derivation-changes-data revisions system)) + #:times 1) + (list system))) + %systems-to-submit-builds-for)) (substitute-availability (with-exception-handler guix-data-service-error->sexp @@ -250,7 +255,7 @@ (package-reproducibility-url branch-commit)))) (values revisions - derivation-changes-data + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master?)) 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/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm index 9bf7997..3530d89 100644 --- a/guix-qa-frontpage/guix-data-service.scm +++ b/guix-qa-frontpage/guix-data-service.scm @@ -4,6 +4,7 @@ #: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) @@ -18,8 +19,10 @@ 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-request @@ -55,69 +58,89 @@ 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-request url #:key (retry-times 0) (retry-delay 5)) (define (make-request) @@ -125,11 +148,6 @@ 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))) - (let ((response body (http-get (string->uri url) @@ -137,29 +155,43 @@ '((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) @@ -184,7 +216,7 @@ "/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 diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm index 94267a5..06192bd 100644 --- a/guix-qa-frontpage/issue.scm +++ b/guix-qa-frontpage/issue.scm @@ -23,7 +23,7 @@ #: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) @@ -179,79 +179,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 +284,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 @@ -312,6 +308,19 @@ (define frequency (* 15 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 3)) + (define (refresh-data) (simple-format (current-error-port) "refreshing patch branches data...\n") @@ -328,6 +337,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 +371,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 +401,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..9b1911f 100644 --- a/guix-qa-frontpage/manage-builds.scm +++ b/guix-qa-frontpage/manage-builds.scm @@ -45,6 +45,7 @@ "i686-linux" "aarch64-linux" "armhf-linux" + "riscv64-linux" "powerpc64le-linux" "i586-gnu")) @@ -89,8 +90,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 +213,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 +243,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 +272,94 @@ (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) + (assoc-ref (branch-derivation-changes-data revisions system) + "derivation_changes")) + %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))) + (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))))))) (define (take* lst n) (if (< (length lst) n) @@ -426,7 +423,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 +463,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 @@ -655,71 +654,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 diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm index 16bfbd9..fc389e1 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -127,7 +127,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 +139,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 +166,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 +195,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 +246,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) @@ -435,7 +438,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 +483,7 @@ (const #t) (lambda () (create-branch-for-issue database + latest-processed-master-revision issue-number patchwork-series)) #:unwind? #t)))) diff --git a/guix-qa-frontpage/patchwork.scm b/guix-qa-frontpage/patchwork.scm index 049012f..08bf62f 100644 --- a/guix-qa-frontpage/patchwork.scm +++ b/guix-qa-frontpage/patchwork.scm @@ -16,10 +16,13 @@ #: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 +80,16 @@ (retry-on-error (lambda () (http-request uri - #:decode-body? #f)) + #:port (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 +174,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 @@ -240,7 +250,10 @@ ;; Need more series, so keep going (let* ((series-batch next-page-uri - (request-patchwork-series patchwork-uri)) + (with-fibers-port-timeouts + (lambda () + (request-patchwork-series patchwork-uri)) + #:timeout 60)) (batch-hash-table (make-hash-table))) @@ -320,6 +333,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..fbfe29c 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -186,7 +186,7 @@ package-reproducibility)))) (('GET "branch" branch) (let ((revisions - derivation-changes + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master @@ -211,7 +211,7 @@ #:sxml (branch-view branch revisions - derivation-changes + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master @@ -595,13 +595,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 @@ -825,6 +824,7 @@ has no patches or has been closed.") database metrics-registry #:key (controller-args '()) submit-builds? + manage-patch-branches? patch-issues-to-show generate-reproducible.json) (define controller @@ -834,6 +834,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 () diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm index f0b47a9..12610f0 100644 --- a/guix-qa-frontpage/utils.scm +++ b/guix-qa-frontpage/utils.scm @@ -21,16 +21,20 @@ #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 threads) + #:use-module (zlib) #:use-module (fibers) #:use-module (fibers channels) - #:use-module ((guix-build-coordinator utils) #:select (with-port-timeouts)) + #:use-module ((guix-build-coordinator utils) #:select (with-port-timeouts + open-socket-for-uri*)) #: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)) + non-blocking + call-with-zlib-input-port*) + #:re-export (with-fibers-port-timeouts + open-socket-for-uri*)) (define* (fiberize proc #:key (parallelism 1)) (let ((channel (make-channel))) @@ -158,3 +162,21 @@ (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..a6a6436 100644 --- a/guix-qa-frontpage/view/branch.scm +++ b/guix-qa-frontpage/view/branch.scm @@ -13,16 +13,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 diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm index 4e851f8..57256ea 100644 --- a/guix-qa-frontpage/view/issue.scm +++ b/guix-qa-frontpage/view/issue.scm @@ -475,5 +475,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/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))))))) |