diff options
| -rw-r--r-- | guix-qa-frontpage/branch.scm | 227 | ||||
| -rw-r--r-- | guix-qa-frontpage/database.scm | 75 | ||||
| -rw-r--r-- | guix-qa-frontpage/guix-data-service.scm | 4 | ||||
| -rw-r--r-- | guix-qa-frontpage/issue.scm | 21 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 149 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 67 | ||||
| -rw-r--r-- | guix-qa-frontpage/patchwork.scm | 86 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 59 | ||||
| -rw-r--r-- | guix-qa-frontpage/utils.scm | 299 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/patches.scm | 46 | ||||
| -rw-r--r-- | scripts/guix-qa-frontpage.in | 63 |
11 files changed, 541 insertions, 555 deletions
diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm index be579f3..719b350 100644 --- a/guix-qa-frontpage/branch.scm +++ b/guix-qa-frontpage/branch.scm @@ -28,6 +28,8 @@ #:select (with-time-logging)) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module (fibers) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage mumi) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage guix-data-service) @@ -41,7 +43,7 @@ get-systems-with-low-substitute-availability - start-refresh-non-patch-branches-data-thread)) + start-refresh-non-patch-branches-data-fiber)) (define (list-non-master-branches) (define (issue-title->branch title) @@ -60,7 +62,12 @@ (cons branch `(("issue_number" . ,issue-number) ("issue_date" . ,(assoc-ref issue "date")) - ("blocked_by" . ,(assoc-ref issue "blocked_by"))))))) + ("blocked_by" + . ,(map (lambda (issue) + (assoc-ref issue "number")) + (or (and=> (assoc-ref issue "blocked_by") + vector->list) + '())))))))) (vector->list (mumi-search-issues ;; TODO: subject: doesn't seem to work for issues where the @@ -69,106 +76,110 @@ (with-exception-handler (lambda (exn) + (simple-format #t "exception listing non master branches: ~A\n" exn) `((exception . ,(simple-format #f "~A" exn)))) (lambda () - (let* ((merge-issues - (merge-issues-by-branch)) - (branches - (map - (lambda (branch) - (let ((name (assoc-ref branch "name"))) - (cons name - (append - (or (assoc-ref merge-issues name) - '()) - (alist-delete "name" branch))))) - (remove - (lambda (branch) - (or (string=? (assoc-ref branch "name") - "master") - (string-prefix? "version-" - (assoc-ref branch "name")) - (string=? (assoc-ref branch "commit") - ""))) - (list-branches - (list-branches-url 2)))))) - (let* ((initial-ordered-branches - (stable-sort - branches - (lambda (a b) - (let ((a-has-issue - (->bool (assoc-ref (cdr a) "issue_number"))) - (b-has-issue - (->bool (assoc-ref (cdr b) "issue_number")))) - (if (and a-has-issue b-has-issue) - (let ((a-date - (assoc-ref (cdr a) "issue_date")) - (b-date - (assoc-ref (cdr b) "issue_date"))) - (string<? a-date b-date)) - a-has-issue))))) - (initial-ordering-index-by-branch - (map (lambda (index branch) - (cons (car branch) index)) + (with-throw-handler #t + (lambda () + (let* ((merge-issues + (merge-issues-by-branch)) + (branches + (map + (lambda (branch) + (let ((name (assoc-ref branch "name"))) + (cons name + (append + (or (assoc-ref merge-issues name) + '()) + (alist-delete "name" branch))))) + (remove + (lambda (branch) + (or (string=? (assoc-ref branch "name") + "master") + (string-prefix? "version-" + (assoc-ref branch "name")) + (string=? (assoc-ref branch "commit") + ""))) + (list-branches + (list-branches-url 2)))))) + (let* ((initial-ordered-branches + (stable-sort + branches + (lambda (a b) + (let ((a-has-issue + (->bool (assoc-ref (cdr a) "issue_number"))) + (b-has-issue + (->bool (assoc-ref (cdr b) "issue_number")))) + (if (and a-has-issue b-has-issue) + (let ((a-date + (assoc-ref (cdr a) "issue_date")) + (b-date + (assoc-ref (cdr b) "issue_date"))) + (string<? a-date b-date)) + a-has-issue))))) + (initial-ordering-index-by-branch + (map (lambda (index branch) + (cons (car branch) index)) + (iota (length initial-ordered-branches)) + initial-ordered-branches)) + (initial-ordering-index-by-issue-number + (filter-map + (lambda (index branch) + (and=> (assoc-ref (cdr branch) "issue_number") + (lambda (issue-number) + (cons issue-number index)))) (iota (length initial-ordered-branches)) - initial-ordered-branches)) - (initial-ordering-index-by-issue-number - (filter-map - (lambda (index branch) - (and=> (assoc-ref (cdr branch) "issue_number") - (lambda (issue-number) - (cons issue-number index)))) - (iota (length initial-ordered-branches)) - initial-ordered-branches))) - - ;; The idea with issues blocking others is to create a linked list, - ;; however I think it's possible to have a loop in the blocking directed - ;; graph, so try to not completely fail if this is the case. - (stable-sort - initial-ordered-branches - (lambda (a b) - (let ((a-initial-ordering-index - (assq-ref initial-ordering-index-by-branch - (car a))) - (b-initial-ordering-index - (assq-ref initial-ordering-index-by-branch - (car b))) - - (a-blocked-by - (map (lambda (issue) - (assoc-ref issue "number")) - (or (and=> (assoc-ref (cdr a) "blocked_by") - vector->list) - '()))) - (b-blocked-by - (map (lambda (issue) - (assoc-ref issue "number")) - (or (and=> (assoc-ref (cdr b) "blocked_by") - vector->list) - '())))) - (< - (if (null? a-blocked-by) - a-initial-ordering-index - (let ((ordering-indexes - (filter-map - (lambda (blocking-issue) - (assq-ref initial-ordering-index-by-issue-number - blocking-issue)) - a-blocked-by))) - (if (null? ordering-indexes) - a-initial-ordering-index - (apply max ordering-indexes)))) - (if (null? b-blocked-by) - b-initial-ordering-index - (let ((ordering-indexes - (filter-map - (lambda (blocking-issue) - (assq-ref initial-ordering-index-by-issue-number - blocking-issue)) - b-blocked-by))) - (if (null? ordering-indexes) - b-initial-ordering-index - (apply max ordering-indexes))))))))))) + initial-ordered-branches))) + + ;; The idea with issues blocking others is to create a linked + ;; list, however I think it's possible to have a loop in the + ;; blocking directed graph, so try to not completely fail if + ;; this is the case. + (stable-sort + initial-ordered-branches + (lambda (a b) + (let ((a-initial-ordering-index + (assq-ref initial-ordering-index-by-branch + (car a))) + (b-initial-ordering-index + (assq-ref initial-ordering-index-by-branch + (car b))) + (a-blocked-by + (or (assoc-ref (cdr a) "blocked_by") '())) + (b-blocked-by + (or (assoc-ref (cdr b) "blocked_by") '()))) + (< + (if (null? a-blocked-by) + a-initial-ordering-index + (let ((ordering-indexes + (filter-map + (lambda (blocking-issue) + (and=> + (assq-ref + initial-ordering-index-by-issue-number + blocking-issue) + 1+)) + a-blocked-by))) + (if (null? ordering-indexes) + a-initial-ordering-index + (apply max ordering-indexes)))) + (if (null? b-blocked-by) + b-initial-ordering-index + (let ((ordering-indexes + (filter-map + (lambda (blocking-issue) + (and=> + (assq-ref + initial-ordering-index-by-issue-number + blocking-issue) + 1+)) + b-blocked-by))) + (if (null? ordering-indexes) + b-initial-ordering-index + (apply max ordering-indexes))))))))))) + (lambda args + (display (backtrace) (current-error-port)) + (newline (current-error-port))))) #:unwind? #t)) (define* (branch-data branch-name) @@ -299,8 +310,8 @@ (vector->list substitute-availability)) "availability")))) -(define (start-refresh-non-patch-branches-data-thread database - metrics-registry) +(define (start-refresh-non-patch-branches-data-fiber database + metrics-registry) (define frequency (* 30 60)) @@ -352,7 +363,9 @@ (define (refresh-data) (simple-format (current-error-port) "refreshing non-patch branches data...\n") - (update-repository!) + (non-blocking + (lambda () + (update-repository!))) (let ((branches (with-sqlite-cache @@ -369,8 +382,7 @@ (list-branches-url 2)))) #:ttl 0))) - (n-par-for-each - 1 + (for-each (lambda (branch) (let ((branch-name (assoc-ref branch "name"))) @@ -428,13 +440,8 @@ "master" master-branch-substitute-availability))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "branch data refresh")) - (const #t)) - (while #t (let ((start-time (current-time))) (with-exception-handler diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm index 5649c36..c44d83a 100644 --- a/guix-qa-frontpage/database.scm +++ b/guix-qa-frontpage/database.scm @@ -36,7 +36,8 @@ #:use-module ((guix-build-coordinator utils fibers) #:select (retry-on-error make-worker-thread-channel - call-with-worker-thread)) + call-with-worker-thread + make-queueing-channel)) #:use-module (guix-qa-frontpage guix-data-service) #:export (setup-database @@ -62,7 +63,8 @@ database? (database-file database-file) (reader-thread-channel database-reader-thread-channel) - (writer-thread-channel database-writer-thread-channel) + (writer-thread-channel database-writer-thread-channel + set-database-writer-thread-channel!) (metrics-registry database-metrics-registry)) (define* (db-open database @@ -254,6 +256,13 @@ PRAGMA optimize;"))) #:delay 5)) (define (database-spawn-fibers database) + ;; Queue messages to the writer thread, so that they're handled in a first + ;; come first served manor + (set-database-writer-thread-channel! + database + (make-queueing-channel + (database-writer-thread-channel database))) + (spawn-fiber (lambda () (while #t @@ -465,39 +474,41 @@ SELECT data, timestamp FROM cache WHERE key = :key" (when (if (procedure? store-computed-value?) (apply store-computed-value? vals) store-computed-value?) - (database-call-with-transaction - database - (lambda (db) - (let ((cleanup-statement - (sqlite-prepare - db - " + (let ((vals-string + (call-with-output-string + (lambda (port) + (write vals port))))) + (database-call-with-transaction + database + (lambda (db) + (let ((cleanup-statement + (sqlite-prepare + db + " DELETE FROM cache WHERE key = :key" - #:cache? #t)) - (insert-statement - (sqlite-prepare - db - " + #:cache? #t)) + (insert-statement + (sqlite-prepare + db + " INSERT INTO cache (key, timestamp, data) VALUES (:key, :timestamp, :data)" - #:cache? #t))) - - (sqlite-bind-arguments - cleanup-statement - #:key string-key) - (sqlite-step cleanup-statement) - (sqlite-reset cleanup-statement) - - (sqlite-bind-arguments - insert-statement - #:key string-key - #:timestamp (time-second (current-time)) - #:data (call-with-output-string - (lambda (port) - (write vals port)))) - - (sqlite-step insert-statement) - (sqlite-reset insert-statement))))) + #:cache? #t))) + + (sqlite-bind-arguments + cleanup-statement + #:key string-key) + (sqlite-step cleanup-statement) + (sqlite-reset cleanup-statement) + + (sqlite-bind-arguments + insert-statement + #:key string-key + #:timestamp (time-second (current-time)) + #:data vals-string) + + (sqlite-step insert-statement) + (sqlite-reset insert-statement)))))) (apply values vals))) (apply values cached-values)))) diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm index 9bf7997..6518cd1 100644 --- a/guix-qa-frontpage/guix-data-service.scm +++ b/guix-qa-frontpage/guix-data-service.scm @@ -143,8 +143,8 @@ (let ((json-body (match (response-content-encoding response) (('gzip) - ;; Stop fibers from triggering dynamic-wind in (zlib) - (call-with-blocked-asyncs + ;; Prevent fibers issues with zlib + (non-blocking (lambda () (call-with-zlib-input-port body diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm index 6ceb733..94267a5 100644 --- a/guix-qa-frontpage/issue.scm +++ b/guix-qa-frontpage/issue.scm @@ -26,6 +26,8 @@ #:select (with-time-logging)) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module (fibers) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage manage-patch-branches) @@ -40,7 +42,7 @@ issue-patches-overall-status issue-data - start-refresh-patch-branches-data-thread)) + start-refresh-patch-branches-data-fiber)) (define reviewed-looks-good-status 'reviewed-looks-good) (define good-status 'important-checks-passing) @@ -303,7 +305,7 @@ builds-missing? comparison-details))) -(define* (start-refresh-patch-branches-data-thread +(define* (start-refresh-patch-branches-data-fiber database metrics-registry #:key number-of-series-to-refresh) @@ -326,10 +328,11 @@ (take latest-series number-of-series-to-refresh) latest-series))) - (update-repository!) + (non-blocking + (lambda () + (update-repository!))) - (n-par-for-each - 5 + (fibers-batch-for-each (match-lambda ((issue-number . series-data) (with-exception-handler @@ -385,15 +388,11 @@ #:args (list issue-number) #:ttl 0))) #:unwind? #t))) + 5 series-to-refresh))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "data refresh")) - (const #t)) - (while #t (let ((start-time (current-time))) (with-exception-handler diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index 1d9a512..d07a773 100644 --- a/guix-qa-frontpage/manage-builds.scm +++ b/guix-qa-frontpage/manage-builds.scm @@ -33,8 +33,11 @@ default-branch-priority-for-change submit-builds-for-branch + submit-build + %fiberized-submit-build + start-submit-patch-builds-fiber - start-submit-branch-builds-thread + start-submit-branch-builds-fiber start-submit-master-branch-system-tests-thread)) (define %systems-to-submit-builds-for @@ -54,6 +57,9 @@ (* (length %systems-to-submit-builds-for) 600)) +(define %fiberized-submit-build + (make-parameter #f)) + (define* (submit-builds-for-issue database build-coordinator @@ -185,7 +191,7 @@ issues-with-builds-to-cancel)) (simple-format #t "submitting patch builds\n") - (for-each + (fibers-batch-for-each (lambda (issue-number) (submit-builds-for-issue database @@ -194,6 +200,7 @@ issue-number #:priority priority-for-change #:build-limit %patches-builds-limit)) + 2 first-n-series-issue-numbers))) (spawn-fiber @@ -248,9 +255,11 @@ (get-commit (string-append "origin/" branch))) (merge-base - (get-git-merge-base - (get-commit "origin/master") - branch-commit)) + (non-blocking + (lambda () + (get-git-merge-base + (get-commit "origin/master") + branch-commit)))) (revisions `((base . ,merge-base) @@ -305,8 +314,7 @@ branch derivations-and-priorities build-ids-to-keep-set - target-commit - #:threads 4))) + target-commit))) (begin (simple-format (current-error-port) @@ -316,24 +324,34 @@ (let ((derivations-and-priorities (fold (lambda (system result) - (vector-fold-right - (lambda (_ result derivation) - (cons - (list - (assoc-ref derivation "derivation") - (if (number? priority) - priority - (priority derivation))) - result)) - result - (assoc-ref - (guix-data-service-request - (package-derivations-url - branch-commit - #:system system - #:target "" - #:no-build-from-build-server "2")) - "derivations"))) + (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 @@ -342,8 +360,7 @@ branch derivations-and-priorities (set) - branch-commit - #:threads 4))))) + branch-commit))))) (simple-format #t "no derivation changes url for branch ~A\n" branch)))) @@ -352,10 +369,10 @@ lst (take lst n))) -(define (start-submit-branch-builds-thread database - build-coordinator - guix-data-service - metrics-registry) +(define (start-submit-branch-builds-fiber database + build-coordinator + guix-data-service + metrics-registry) (define (cancel-branch-builds branches) (for-each (lambda (branch) @@ -440,13 +457,8 @@ (current-error-port) "waiting for master branch substitutes before submitting branch builds\n"))))))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "branch builds")) - (const #t)) - (while #t (with-exception-handler (lambda (exn) @@ -486,7 +498,7 @@ #t #t tags)) - #:timeout 60))) + #:timeout 240))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response @@ -550,7 +562,7 @@ (unless (null? uuids-batch) (loop (fetch-build-uuids))))) - #:timeout 60) + #:timeout 120) (simple-format (current-error-port) "finshed canceling builds for ~A ~A\n" category-name @@ -717,33 +729,28 @@ build-ids-to-keep-set target-commit #:key build-limit - (build-count-priority-penalty (const 0)) - (threads 1)) + (build-count-priority-penalty (const 0))) (define (submit-builds build-details build-ids-to-keep-set) + (define submit-build/fiberized + (%fiberized-submit-build)) + (define submit-single (match-lambda ((derivation priority) - (submit-build build-coordinator - guix-data-service - derivation - #:priority priority - #:tags - `(((key . category) - (value . package)) - ((key . ,category-name) - (value . ,category-value)) - ((key . revision) - (value . ,target-commit))))))) - - (if (= threads 1) - (for-each - submit-single - build-details) - (n-par-for-each - threads - submit-single - build-details))) + (submit-build/fiberized build-coordinator + guix-data-service + derivation + #:priority priority + #:tags + `(((key . category) + (value . package)) + ((key . ,category-name) + (value . ,category-value)) + ((key . revision) + (value . ,target-commit))))))) + + (fibers-for-each submit-single build-details)) (let ((builds-to-submit-count (length derivations-and-priorities))) @@ -752,14 +759,18 @@ category-name category-value) - ;; Cancel builds first, as some of the builds we want to submit might be - ;; for the same outputs as ones we're going to cancel. - (cancel-builds-not-for-revision - build-coordinator - category-name - category-value - target-commit - build-ids-to-keep-set) + (retry-on-error + (lambda () + ;; Cancel builds first, as some of the builds we want to submit might be + ;; for the same outputs as ones we're going to cancel. + (cancel-builds-not-for-revision + build-coordinator + category-name + category-value + target-commit + build-ids-to-keep-set)) + #:times 3 + #:delay 2) (if (or (not build-limit) (< builds-to-submit-count diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm index c3ae256..16bfbd9 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -30,8 +30,6 @@ #:use-module (guix-qa-frontpage guix-data-service) #:export (create-branch-for-issue - patchwork-series->branch - start-manage-patch-branches-thread get-issue-branch-base-and-target-refs)) @@ -129,64 +127,6 @@ (close-pipe pipe) result)) -(define (parse-patch-name name) - (let ((args - (and - (string-prefix? "[" name) - (let ((stop (string-index name #\]))) - (substring name 1 stop)))) - (as-bug-number - (lambda (arg) - (and (string-prefix? "bug#" arg) - (string->number (substring arg (string-length "bug#")))))) - (as-v2 - (lambda (arg) - (and (string-prefix? "v" arg) - (string->number (substring arg 1))))) - (as-patch-number - (lambda (arg) - (match (string-split arg #\/) - (((= string->number index) (= string->number total)) - (and index total (<= index total) - (cons index total))) - (else #f))))) - (let analyze ((bug-number #f) - (branch "master") - (version 1) - (index 1) - (total 1) - (arguments - (if args - (string-split args #\,) - '()))) - (match arguments - ((or ("") ()) - `((bug-number . ,bug-number) - (branch . ,branch) - (version . ,version) - (index . ,index) - (total . ,total))) - (((= as-bug-number (? number? new-bug-number)) - arguments ...) - (analyze new-bug-number branch version index total arguments)) - (((= as-v2 (? number? new-version)) - arguments ...) - (analyze bug-number branch new-version index total arguments)) - (((= as-patch-number ((? number? new-index) . (? number? new-total))) - arguments ...) - (analyze bug-number branch version new-index new-total arguments)) - ((feature-branch arguments ...) - (analyze bug-number feature-branch version index total arguments)))))) - -(define (patchwork-series->branch series) - (match (assoc-ref series "patches") - (#() "master") - (#(first-patch rest ...) - (let ((details - (parse-patch-name - (assoc-ref first-patch "name")))) - (assq-ref details 'branch))))) - (define (create-branch-for-issue database issue-number patchwork-series) (define branch-name (simple-format #f "issue-~A" issue-number)) @@ -196,7 +136,7 @@ (define (get-base-commit) (let ((branch - (patchwork-series->branch patchwork-series))) + (assq-ref patchwork-series 'branch))) (if (string=? branch "master") (get-latest-processed-branch-revision "master") @@ -424,8 +364,9 @@ (assq-ref (get-issue-branch-base-and-target-refs issue-number) 'base)) - (branch (patchwork-series->branch - (assq-ref all-patchwork-series issue-number)))) + (branch + (assq-ref (assq-ref all-patchwork-series issue-number) + 'branch))) (with-exception-handler (lambda (exn) (if (and (guix-data-service-error? exn) diff --git a/guix-qa-frontpage/patchwork.scm b/guix-qa-frontpage/patchwork.scm index 8f9d570..049012f 100644 --- a/guix-qa-frontpage/patchwork.scm +++ b/guix-qa-frontpage/patchwork.scm @@ -98,6 +98,75 @@ (assq-ref link-details 'uri) (uri-scheme uri)))))))))) +(define (parse-patch-name name) + (let ((args + (and + (string-prefix? "[" name) + (let ((stop (string-index name #\]))) + (substring name 1 stop)))) + (as-bug-number + (lambda (arg) + (and (string-prefix? "bug#" arg) + (string->number (substring arg (string-length "bug#")))))) + (as-v2 + (lambda (arg) + (and (string-prefix? "v" arg) + (string->number (substring arg 1))))) + (as-patch-number + (lambda (arg) + (match (string-split arg #\/) + (((= string->number index) (= string->number total)) + (and index total (<= index total) + (cons index total))) + (else #f))))) + (let analyze ((bug-number #f) + (branch "master") + (version 1) + (index 1) + (total 1) + (arguments + (if args + (string-split args #\,) + '()))) + (match arguments + ((or ("") ()) + `((bug-number . ,bug-number) + (branch . ,branch) + (version . ,version) + (index . ,index) + (total . ,total))) + (((= as-bug-number (? number? new-bug-number)) + arguments ...) + (analyze new-bug-number branch version index total arguments)) + (((= as-v2 (? number? new-version)) + arguments ...) + (analyze bug-number branch new-version index total arguments)) + (((= as-patch-number ((? number? new-index) . (? number? new-total))) + arguments ...) + (analyze bug-number branch version new-index new-total arguments)) + ((feature-branch arguments ...) + (analyze bug-number feature-branch version index total arguments)))))) + +(define parse-issue-title + (let ((regex (make-regexp "\\[([A-Z\\_a-z0-9\\-]+)\\].*"))) + (lambda (title) + (match (regexp-exec regex title) + (#f #f) + (m + (let ((branch (match:substring m 1))) + (if (string=? branch "PATCH") + #f + branch))))))) + +(define (patchwork-series->branch series) + (match (assoc-ref series "patches") + (#() "master") + (#(first-patch rest ...) + (let ((details + (parse-patch-name + (assoc-ref first-patch "name")))) + (assq-ref details 'branch))))) + (define* (latest-patchwork-series-by-issue #:key patchwork count) @@ -107,6 +176,12 @@ (string-match "\\[?bug#([0-9]*)(,|:|\\])" str) 1))) + (define (strip-title-prefix str) + (if (string-prefix? "[" str) + (let ((start (string-index str #\]))) + (string-drop str (+ 1 start))) + str)) + (define issue-number-to-series-hash-table (make-hash-table)) @@ -230,8 +305,15 @@ #t)) (assq-ref mumi 'merged-with))) (cons - `(,@data - (mumi . ,mumi)) + `(,issue-number + . + (("name" . ,(strip-title-prefix + (assq-ref mumi 'title))) + ,@(alist-delete "name" (cdr data) string=?) + (branch . ,(or (parse-issue-title + (assq-ref mumi 'title)) + (patchwork-series->branch data))) + (mumi . ,mumi))) result) result))) result diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 8db6aae..ccfa985 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -35,6 +35,8 @@ #:use-module (guix store) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module ((guix-data-service utils) + #:select (delete-duplicates/sort!)) #:use-module (guix-data-service web util) #:use-module ((guix-data-service web query-parameters) #:select (parse-query-string)) @@ -52,6 +54,7 @@ #:use-module (guix-qa-frontpage branch) #:use-module (guix-qa-frontpage package) #:use-module (guix-qa-frontpage issue) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage manage-patch-branches) @@ -151,9 +154,10 @@ #:code 200 #:headers '((content-type . (text/plain)) (vary . (accept)))) - (lambda (port) - (write-metrics metrics-registry port) - (write-metrics plain-metrics-registry port)))) + (call-with-output-string + (lambda (port) + (write-metrics metrics-registry port) + (write-metrics plain-metrics-registry port))))) (('GET "branches") (let ((branches (with-sqlite-cache @@ -260,16 +264,13 @@ symbol-key #f)))) query-params)) - (latest-series-branches - (map - (match-lambda - ((_ . series) - (patchwork-series->branch series))) - latest-series)) (branch-options - (sort (delete-duplicates - latest-series-branches) - string<?)) + (reverse + (delete-duplicates/sort! + (map (lambda (series) + (assq-ref series 'branch)) + latest-series) + string<?))) (filtered-branches (filter-map (match-lambda @@ -280,7 +281,7 @@ query-params)) (latest-series-with-overall-statuses (filter-map - (lambda (series branch) + (lambda (series) (let ((overall-status (with-sqlite-cache database @@ -288,7 +289,9 @@ (const 'unknown) #:store-computed-value? #f #:args (list (first series)) - #:ttl 3600))) + #:ttl 3600)) + (branch + (assq-ref series 'branch))) (if (and (or (null? filtered-statuses) (member overall-status filtered-statuses)) @@ -298,8 +301,7 @@ `((branch . ,branch) (overall-status . ,overall-status))) #f))) - latest-series - latest-series-branches)) + latest-series)) (sorted-latest-series (sort latest-series-with-overall-statuses @@ -619,8 +621,6 @@ (select-create-branch-for-issue-log database number)) - (branch - (patchwork-series->branch series)) (master-branch-substitute-availability systems-with-low-substitute-availability master-branch-package-reproducibility @@ -633,7 +633,7 @@ (render-html #:sxml (issue-view number series - branch + (assq-ref series 'branch) (assq-ref (assq-ref series 'mumi) 'tags) base-and-target-refs @@ -844,14 +844,30 @@ 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 + #:number-of-series-to-refresh patch-issues-to-show) + + (start-refresh-non-patch-branches-data-fiber database + metrics-registry) + (when submit-builds? (start-submit-patch-builds-fiber database "http://127.0.0.1:8746" "https://data.qa.guix.gnu.org" metrics-registry #:series-count - patch-issues-to-show)) + patch-issues-to-show) + (start-submit-branch-builds-fiber database + "http://127.0.0.1:8746" + "https://data.qa.guix.gnu.org" + metrics-registry)) (wait finished?)) + #:hz 0 #:parallelism 1))) (call-with-sigint @@ -881,5 +897,6 @@ has no patches or has been closed.") #:port port) (wait finished?)) - #:parallelism 2)) + #:hz 0 + #:parallelism 1)) finished?))) diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm index d96db57..f0b47a9 100644 --- a/guix-qa-frontpage/utils.scm +++ b/guix-qa-frontpage/utils.scm @@ -18,172 +18,143 @@ (define-module (guix-qa-frontpage utils) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (ice-9 q) - #:use-module (ice-9 iconv) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) - #:use-module (ice-9 format) #:use-module (ice-9 threads) - #:use-module (ice-9 atomic) - #:use-module (ice-9 textual-ports) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 exceptions) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 suspendable-ports) - #:use-module ((ice-9 ports internal) #:select (port-poll - port-read-wait-fd - port-write-wait-fd)) - #:use-module (web uri) - #:use-module (web http) - #:use-module (web client) - #:use-module (web request) - #:use-module (web response) #:use-module (fibers) - #:use-module (fibers timers) #:use-module (fibers channels) - #:use-module (fibers scheduler) - #:use-module (fibers conditions) - #:use-module (fibers operations) - #:export (port-read-timeout-error? - port-write-timeout-error? - with-fibers-port-timeouts)) - -(define (readable? port) - "Test if PORT is writable." - (match (select (vector port) #() #() 0) - ((#() #() #()) #f) - ((#(_) #() #()) #t))) - -(define (writable? port) - "Test if PORT is writable." - (match (select #() (vector port) #() 0) - ((#() #() #()) #f) - ((#() #(_) #()) #t))) - -(define (make-wait-operation ready? schedule-when-ready port port-ready-fd this-procedure) - (make-base-operation #f - (lambda _ - (and (ready? (port-ready-fd port)) values)) - (lambda (flag sched resume) - (define (commit) - (match (atomic-box-compare-and-swap! flag 'W 'S) - ('W (resume values)) - ('C (commit)) - ('S #f))) - (schedule-when-ready - sched (port-ready-fd port) commit)))) - -(define (wait-until-port-readable-operation port) - "Make an operation that will succeed when PORT is readable." - (unless (input-port? port) - (error "refusing to wait forever for input on non-input port")) - (make-wait-operation readable? schedule-task-when-fd-readable port - port-read-wait-fd - wait-until-port-readable-operation)) - -(define (wait-until-port-writable-operation port) - "Make an operation that will succeed when PORT is writable." - (unless (output-port? port) - (error "refusing to wait forever for output on non-output port")) - (make-wait-operation writable? schedule-task-when-fd-writable port - port-write-wait-fd - wait-until-port-writable-operation)) - - - -(define &port-timeout - (make-exception-type '&port-timeout - &external-error - '(port))) - -(define make-port-timeout-error - (record-constructor &port-timeout)) - -(define port-timeout-error? - (record-predicate &port-timeout)) - -(define &port-read-timeout - (make-exception-type '&port-read-timeout - &port-timeout - '())) - -(define make-port-read-timeout-error - (record-constructor &port-read-timeout)) - -(define port-read-timeout-error? - (record-predicate &port-read-timeout)) - -(define &port-write-timeout - (make-exception-type '&port-write-timeout - &port-timeout - '())) - -(define make-port-write-timeout-error - (record-constructor &port-write-timeout)) - -(define port-write-timeout-error? - (record-predicate &port-write-timeout)) - -(define* (with-fibers-port-timeouts thunk - #:key timeout - (read-timeout timeout) - (write-timeout timeout)) - (define (no-fibers-wait port mode timeout) - (define poll-timeout-ms 200) - - ;; When the GC runs, it restarts the poll syscall, but the timeout - ;; remains unchanged! When the timeout is longer than the time - ;; between the syscall restarting, I think this renders the - ;; timeout useless. Therefore, this code uses a short timeout, and - ;; repeatedly calls poll while watching the clock to see if it has - ;; timed out overall. - (let ((timeout-internal - (+ (get-internal-real-time) - (* internal-time-units-per-second - timeout)))) - (let loop ((poll-value - (port-poll port mode poll-timeout-ms))) - (if (= poll-value 0) - (if (> (get-internal-real-time) - timeout-internal) - (raise-exception - (if (string=? mode "r") - (make-port-read-timeout-error port) - (make-port-write-timeout-error port))) - (loop (port-poll port mode poll-timeout-ms))) - poll-value)))) - - (unless read-timeout - (if timeout - (error "unset read-timeout") - (error "unset timeout"))) - (unless write-timeout - (error "unset write-timeout")) - - (parameterize - ((current-read-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-readable-operation port) - (wrap-operation - (sleep-operation read-timeout) - (lambda () - (raise-exception - (make-port-read-timeout-error thunk port)))))) - (no-fibers-wait port "r" read-timeout)))) - (current-write-waiter - (lambda (port) - (if (current-scheduler) - (perform-operation - (choice-operation - (wait-until-port-writable-operation port) - (wrap-operation - (sleep-operation write-timeout) + #: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 () - (raise-exception - (make-port-write-timeout-error thunk port)))))) - (no-fibers-wait port "w" write-timeout))))) - (thunk))) + (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)) + +(define (non-blocking thunk) + (let ((channel (make-channel))) + (call-with-new-thread + (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))) + (match (get-message channel) + (('values . results) + (apply values results)) + (('exception . exn) + (raise-exception exn))))) diff --git a/guix-qa-frontpage/view/patches.scm b/guix-qa-frontpage/view/patches.scm index fc5c575..dc0af45 100644 --- a/guix-qa-frontpage/view/patches.scm +++ b/guix-qa-frontpage/view/patches.scm @@ -127,47 +127,11 @@ will appear first.") ,id)) (td (@ (style "vertical-align: middle;")) - ,@(cond - ((eq? status 'reviewed-looks-good) - `((span (@ (aria-label "status: darkgreen") - (class "darkgreen-dot")) - (*ENTITY* "#10004")))) - ((eq? status 'important-checks-passing) - `((span (@ (aria-label "status: green") - (class "green-dot")) - (*ENTITY* "#10004")))) - ((eq? status 'important-checks-failing) - `((span (@ (aria-label "status: red") - (class "red-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'failed-to-apply-patches) - `((span (@ (aria-label "status: darkred") - (class "darkred-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'large-number-of-builds) - `((span (@ (aria-label "status: purple") - (class "purple-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'waiting-for-build-results) - `((span (@ (aria-label "status: lightblue") - (class "lightblue-dot")) - (*ENTITY* "#127959")))) - ((eq? status 'patches-missing) - `((span (@ (aria-label "status: pink") - (class "pink-dot")) - "?"))) - ((eq? status 'guix-data-service-failed) - `((span (@ (aria-label "status: yellow") - (class "yellow-dot")) - (*ENTITY* "#10005")))) - ((eq? status 'needs-looking-at) - `((span (@ (aria-label "status: orange") - (class "orange-dot")) - (*ENTITY* "#9888")))) - (else - `((span (@ (aria-label "status: grey") - (class "grey-dot")) - "?"))))) + ,(status->issue-status-span status)) (td (@ (style "text-align: left;")) + ,@(let ((branch (assq-ref details 'branch))) + (if (string=? branch "master") + '() + `((code ,branch)))) ,(assoc-ref details "name")))))) latest-series))))))) diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in index 488a0b0..eee3b4c 100644 --- a/scripts/guix-qa-frontpage.in +++ b/scripts/guix-qa-frontpage.in @@ -265,46 +265,29 @@ (assq-ref opts 'host) (assq-ref opts 'port)) - (parameterize - ((%git-repository-location (string-append (getcwd) "/guix.git"))) - (let* ((metrics-registry (make-metrics-registry - #:namespace - "guixqafrontpage")) - (database - (setup-database (assq-ref opts 'database) - metrics-registry))) + (with-fluids ((%file-port-name-canonicalization 'none)) + (parameterize + ((%git-repository-location (string-append (getcwd) "/guix.git"))) + (let* ((metrics-registry (make-metrics-registry + #:namespace + "guixqafrontpage")) + (database + (setup-database (assq-ref opts 'database) + metrics-registry))) - (start-refresh-patch-branches-data-thread - database - metrics-registry - #:number-of-series-to-refresh patch-issues-to-show) - (start-refresh-non-patch-branches-data-thread database - metrics-registry) + (when (assq-ref opts 'manage-patch-branches) + (start-manage-patch-branches-thread database + metrics-registry + #:series-count patch-issues-to-show)) - (when (assq-ref opts 'submit-builds) - (start-submit-branch-builds-thread database - "http://127.0.0.1:8746" - "https://data.qa.guix.gnu.org" - metrics-registry) - (start-submit-master-branch-system-tests-thread + (start-guix-qa-frontpage + (assq-ref opts 'port) + (assq-ref opts 'host) + (assq-ref opts 'assets-directory) database - "http://127.0.0.1:8746" - "https://data.qa.guix.gnu.org" - 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) - (assq-ref opts 'assets-directory) - database - metrics-registry - #:controller-args `(#:doc-dir ,doc-dir - #:patch-issues-to-show ,patch-issues-to-show) - #:submit-builds? (assq-ref opts 'submit-builds) - #:patch-issues-to-show patch-issues-to-show - #:generate-reproducible.json #t)))))) + metrics-registry + #:controller-args `(#:doc-dir ,doc-dir + #:patch-issues-to-show ,patch-issues-to-show) + #:submit-builds? (assq-ref opts 'submit-builds) + #:patch-issues-to-show patch-issues-to-show + #:generate-reproducible.json #t))))))) |