(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 sets)
#: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)
#:use-module (guix-qa-frontpage manage-patch-branches)
#:export (%systems-to-submit-builds-for
builds-missing-for-derivation-changes?
start-submit-patch-builds-thread
start-submit-branch-builds-thread
start-submit-master-branch-system-tests-thread))
(define %systems-to-submit-builds-for
'("x86_64-linux"
"i686-linux"
"aarch64-linux"
"armhf-linux"
"powerpc64le-linux"
"i586-gnu"))
(define* (start-submit-patch-builds-thread database
build-coordinator
guix-data-service
#:key (series-count 200))
(define (priority-for-change change)
(if (member (assoc-ref change "system")
'("x86_64-linux" "aarch64-linux"))
550
350))
(define (submit-builds)
(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)))
(n-par-for-each
4
(match-lambda
((issue-number . series)
(simple-format #t
"considering submitting builds for issue ~A\n"
issue-number)
(let ((derivation-changes-url
(and=>
(get-issue-branch-base-and-target-refs issue-number)
(lambda (base-and-target-refs)
(patch-series-derivation-changes-url
base-and-target-refs
#:systems %systems-to-submit-builds-for)))))
(if derivation-changes-url
(let ((derivation-changes-data
change-details
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"failed fetching derivation changes for issue ~A: ~A\n"
issue-number
exn)
(values #f #f))
(lambda ()
(with-sqlite-cache
database
'derivation-changes
derivation-changes
#:args
(list derivation-changes-url)
#:ttl (* 60 20)))
#:unwind? #t)))
(when derivation-changes-data
(let ((target-commit
(assoc-ref
(assoc-ref
(assoc-ref change-details
"revisions")
"target")
"commit")))
(submit-builds-for-category build-coordinator
guix-data-service
'issue
issue-number
derivation-changes-data
target-commit
#:build-limit
(* (length %systems-to-submit-builds-for)
600)
#:priority priority-for-change
#:build-count-priority-penalty
(lambda (build-count)
(cond
((< build-count 10) 0)
((< build-count 100) 50)
((< build-count 300) 100)
(else 150)))))))
(simple-format #t "no derivation changes url for issue ~A\n"
issue-number)))))
(take series series-count))))
(call-with-new-thread
(lambda ()
(while #t
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception in submit patch builds thread: ~A\n"
exn))
(lambda ()
(with-throw-handler #t
submit-builds
(lambda args
(display (backtrace) (current-error-port))
(newline (current-error-port)))))
#:unwind? #t)
(sleep 300)))))
(define (start-submit-branch-builds-thread database
build-coordinator
guix-data-service)
(define (submit-builds)
(define (priority-for-change change)
(if (member (assoc-ref change "system")
'("x86_64-linux" "aarch64-linux"))
100
0))
(simple-format #t "submitting branch builds\n")
(let ((branches '("core-updates")))
(for-each
(lambda (branch)
(simple-format #t
"considering submitting builds for branch ~A\n"
branch)
(let ((derivation-changes-url
(branch-derivation-changes-url
branch
#:systems %systems-to-submit-builds-for)))
(if derivation-changes-url
(let ((derivation-changes-data
change-details
(with-sqlite-cache
database
'branch-derivation-changes
derivation-changes
#:args
(list derivation-changes-url)
#:ttl 0)))
(when derivation-changes-data
(let ((target-commit
(assoc-ref
(assoc-ref
(assoc-ref change-details
"revisions")
"target")
"commit")))
(submit-builds-for-category build-coordinator
guix-data-service
'branch
branch
derivation-changes-data
target-commit
#:priority priority-for-change))))
(simple-format #t "no derivation changes url for branch ~A\n"
branch))))
branches)))
(call-with-new-thread
(lambda ()
(while #t
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception in submit branch builds thread: ~A\n"
exn))
(lambda ()
(with-throw-handler #t
submit-builds
(lambda args
(display (backtrace) (current-error-port))
(newline (current-error-port)))))
#:unwind? #t)
(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)
(let ((next-builds
(builds-after
(assoc-ref (last builds) "uuid"))))
(loop
(if (null? next-builds)
(builds-after #f)
next-builds))))))
(define (cancel-builds-not-for-revision build-coordinator
category-name
category-value
revision
build-ids-to-keep-set)
(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 (set-contains?
build-ids-to-keep-set
(assoc-ref build-details "uuid"))
(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
#:relationship 'no-dependent-builds))
(define (builds-missing-for-derivation-changes? derivation-changes)
(any
(lambda (change)
(if (and (string=? (assoc-ref change "target")
"")
(member (assoc-ref change "system")
%systems-to-submit-builds-for))
(if (= (vector-length
(assoc-ref change "builds"))
0)
#t
#f)
#f))
(append-map! (lambda (package)
(vector->list
(assoc-ref package "target")))
derivation-changes)))
(define* (submit-builds-for-category build-coordinator
guix-data-service
category-name
category-value
derivation-changes
target-commit
#:key build-limit
priority
(build-count-priority-penalty (const 0)))
(define (submit-builds build-details
build-ids-to-keep-set)
(for-each
(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))))))
build-details)
;; TODO Don't currently cancel builds
;; I think this approach has some problems and needs more thinking about.
;;
;; (cancel-builds-not-for-revision
;; build-coordinator
;; category-name
;; category-value
;; target-commit
;; build-ids-to-keep-set)
)
(let loop ((changes
(append-map! (lambda (package)
(vector->list
(assoc-ref package "target")))
derivation-changes))
(builds-to-submit-details '())
(build-ids-to-keep-set (set)))
(if (null? changes)
(let ((builds-to-submit-count
(length builds-to-submit-details)))
(simple-format #t "~A target derivations for ~A ~A\n"
builds-to-submit-count
category-name
category-value)
(if (or (not build-limit)
(< builds-to-submit-count
build-limit))
(submit-builds (let ((priority-penalty
(build-count-priority-penalty
builds-to-submit-count)))
(if (= 0 priority-penalty)
builds-to-submit-details
(map
(match-lambda
((derivation priority)
(list derivation
(- priority priority-penalty))))
builds-to-submit-details)))
build-ids-to-keep-set)
(simple-format #t "skipping ~A ~A as too many target derivations (~A)\n"
category-name
category-value
builds-to-submit-count)))
(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-length
(assoc-ref change "builds"))
0)
(cons
(list (assoc-ref change "derivation-file-name")
(if (number? priority)
priority
(priority change)))
builds-to-submit-details)
builds-to-submit-details) ; build exists
(fold (lambda (build result)
(if (member (assoc-ref build "status")
'("scheduled" "started"))
(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))))))
(define %system-tests-that-change-every-revision
'("btrfs-raid10-root-os"
"btrfs-raid10-root-os-degraded"
"btrfs-raid-root-os"
"btrfs-root-on-subvolume-os"
"btrfs-root-os"
"docker-system"
"encrypted-home-os"
"encrypted-root-not-boot-os"
"encrypted-root-os"
"f2fs-root-os"
"gui-installed-desktop-os-encrypted"
"gui-installed-os"
"gui-installed-os-encrypted"
"gui-uefi-installed-os"
"installed-extlinux-os"
"installed-os"
"iso-image-installer"
"jfs-root-os"
"lvm-separate-home-os"
"raid-root-os"
"separate-home-os"
"separate-store-os"
"xfs-root-os"))
(define (start-submit-master-branch-system-tests-thread database
build-coordinator
guix-data-service)
(define %systems
'())
(define (submit-builds)
(simple-format #t "submitting system test builds\n")
(let* ((processed-revision-commits
(filter-map
(lambda (revision-details)
(if (assoc-ref revision-details "data_available")
(assoc-ref revision-details "commit-hash")
#f))
(branch-revisions
(branch-revisions-url 2 "master"))))
(recent-processed-revision-commits
(if (> (length processed-revision-commits)
5)
(take processed-revision-commits 5)
5)))
(for-each
(lambda (commit)
(for-each
(lambda (system)
(let* ((system-tests
(revision-system-tests
(revision-system-tests-url
commit #:system system))))
(for-each
(lambda (system-test-details)
(let ((name
(assoc-ref system-test-details "name"))
(builds
(assoc-ref system-test-details "builds")))
(when (and (not
(member name
%system-tests-that-change-every-revision))
(= (vector-length builds) 0))
(submit-build build-coordinator
guix-data-service
(assoc-ref system-test-details "derivation")
#:tags
`(((key . category)
(value . system-test))
((key . branch)
(value . master))
((key . revision)
(value . ,commit)))))))
system-tests)))
%systems))
recent-processed-revision-commits)))
(call-with-new-thread
(lambda ()
(while #t
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception in submit system test builds thread: ~A\n"
exn))
(lambda ()
(with-throw-handler #t
submit-builds
(lambda args
(display (backtrace) (current-error-port))
(newline (current-error-port)))))
#:unwind? #t)
(sleep 3600)))))