(define-module (guix-qa-frontpage manage-builds) #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (guix-build-coordinator utils) #:use-module (guix-build-coordinator client-communication) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage patchwork) #:use-module (guix-qa-frontpage guix-data-service) #:export (%systems-to-submit-builds-for start-submit-patch-builds-thread start-submit-branch-builds-thread)) (define %systems-to-submit-builds-for '("x86_64-linux" "i686-linux" "aarch64-linux" "armhf-linux")) (define (start-submit-patch-builds-thread database build-coordinator guix-data-service) (call-with-new-thread (lambda () (while #t (simple-format #t "submitting patch builds\n") (let ((series (with-sqlite-cache database 'latest-patchwork-series-by-issue latest-patchwork-series-by-issue #:ttl 3000))) (for-each (match-lambda ((issue-number . series) (simple-format #t "considering submitting builds for issue ~A\n" issue-number) (let ((derivation-changes-url (patch-series-derivation-changes-url series))) (if derivation-changes-url (let ((derivation-changes change-details (with-sqlite-cache database 'derivation-changes patch-series-derivation-changes #:args (list derivation-changes-url) #:ttl 6000))) (when derivation-changes (let ((target-commit (assoc-ref (assoc-ref (assoc-ref change-details "revisions") "target") "commit"))) (submit-builds-for-issue build-coordinator guix-data-service issue-number derivation-changes target-commit)))) (simple-format #t "no derivation changes url for issue ~A\n" issue-number))))) (take series 50))) (sleep 300))))) (define (start-submit-branch-builds-thread database build-coordinator guix-data-service) (call-with-new-thread (lambda () (while #t (simple-format #t "submitting branch builds\n") (let ((branches '("staging"))) (for-each (lambda (branch) (simple-format #t "considering submitting builds for branch ~A\n" branch) (let ((derivation-changes-url (branch-derivation-changes-url branch))) (if derivation-changes-url (let ((derivation-changes change-details (with-sqlite-cache database 'branch-derivation-changes branch-derivation-changes #:args (list derivation-changes-url) #:ttl 0))) (when derivation-changes (let ((target-commit (assoc-ref (assoc-ref (assoc-ref change-details "revisions") "target") "commit"))) (submit-builds-for-branch build-coordinator guix-data-service branch derivation-changes target-commit)))) (simple-format #t "no derivation changes url for branch ~A\n" branch)))) branches)) (sleep 3600))))) (define* (submit-build build-coordinator guix-data-service derivation #:key (priority 0) (tags '())) (retry-on-error (lambda () (let ((response (send-submit-build-request build-coordinator derivation (list guix-data-service) #f priority #t #t #t tags))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response (simple-format #t "skipped: ~A\n" no-build-submitted-response) (simple-format #t "build submitted as ~A\n" (assoc-ref response "build-submitted")))))) ;; The TTL Guix uses for transient failures fetching substitutes is 10 ;; minutes, so we need to retry for longer than that #:times 30 #:delay 30)) (define (for-each-build build-coordinator proc . criteria) (define (builds-after id) (vector->list (assoc-ref (apply request-builds-list build-coordinator (append criteria `(#:limit 1000 #:after-id ,id))) "builds"))) (let loop ((builds (builds-after #f))) (for-each proc builds) (unless (null? builds) (loop (builds-after (assoc-ref (last builds) "uuid")))))) (define (cancel-builds-not-for-revision build-coordinator category-name category-value revision derivations) (simple-format (current-error-port) "canceling builds for ~A ~A and not revision ~A\n" category-name category-value revision) (for-each-build build-coordinator (lambda (build-details) (unless (member derivations (assoc-ref build-details "derivation-name")) (retry-on-error (lambda () (send-cancel-build-request build-coordinator (assoc-ref build-details "uuid"))) #:times 6 #:delay 15) (simple-format (current-error-port) "canceled ~A\n" (assoc-ref build-details "uuid")))) #:tags `(((key . category) (value . package)) ((key . ,category-name) (value . ,category-value))) #:not-tags `(((key . revision) (value . ,revision))) #:canceled #f #:processed #f)) (define* (submit-builds-for-issue build-coordinator guix-data-service issue derivation-changes target-commit) (define target-derivations (fold (lambda (package result) (fold (lambda (change result) (if (and (string=? (assoc-ref change "target") "") (member (assoc-ref change "system") %systems-to-submit-builds-for) (eq? (vector-length (assoc-ref change "builds")) 0)) (cons (assoc-ref change "derivation-file-name") result) result)) result (vector->list (assoc-ref package "target")))) '() derivation-changes)) (define target-derivations-length (length target-derivations)) (simple-format #t "~A target derivations for issue ~A\n" target-derivations-length issue) (if (< target-derivations-length 200) (for-each (lambda (derivation) (submit-build build-coordinator guix-data-service derivation #:priority 0 #:tags `(((key . category) (value . package)) ((key . issue) (value . ,issue)) ((key . revision) (value . ,target-commit))))) target-derivations) (simple-format #t "skipping issue ~A as too many target derivations (~A)\n" issue target-derivations-length)) (cancel-builds-not-for-revision build-coordinator 'issue issue target-commit target-derivations)) (define* (submit-builds-for-branch build-coordinator guix-data-service branch derivation-changes target-commit) (define target-derivations (fold (lambda (package result) (fold (lambda (change result) (if (and (string=? (assoc-ref change "target") "") (member (assoc-ref change "system") %systems-to-submit-builds-for) (eq? (vector-length (assoc-ref change "builds")) 0)) (cons (assoc-ref change "derivation-file-name") result) result)) result (vector->list (assoc-ref package "target")))) '() derivation-changes)) (define target-derivations-length (length target-derivations)) (simple-format #t "~A target derivations for branch ~A\n" target-derivations-length branch) (for-each (lambda (derivation) (submit-build build-coordinator guix-data-service derivation #:priority -100 #:tags `(((key . category) (value . package)) ((key . branch) (value . ,branch)) ((key . revision) (value . ,target-commit))))) target-derivations) (cancel-builds-not-for-revision build-coordinator 'branch branch target-commit target-derivations))