meta/pkg-build: run raco test --drdr for each package
This commit is contained in:
Matthew Flatt
parent
abf76be7f0
commit
e381192e6e
|
|
@ -58,7 +58,7 @@
|
|||
;; - tier-based selection of packages on conflict
|
||||
;; - support for running tests
|
||||
|
||||
(struct vm (host user dir name init-snapshot installed-snapshot minimal-variant))
|
||||
(struct vm (name host user dir env init-snapshot installed-snapshot minimal-variant))
|
||||
|
||||
;; Each VM must provide at least an ssh server and `tar`, and the
|
||||
;; intent is that it is otherwise isolated (e.g., no network
|
||||
|
|
@ -72,6 +72,8 @@
|
|||
#:user [user "racket"]
|
||||
;; Working directory on VM:
|
||||
#:dir [dir "/home/racket/build-pkgs"]
|
||||
;; Enviornment variables as (list (cons <str> <str>) ...)
|
||||
#:env [env null]
|
||||
;; Name of a clean starting snapshot in the VM:
|
||||
#:init-shapshot [init-snapshot "init"]
|
||||
;; An "installed" snapshot is created after installing Racket
|
||||
|
|
@ -82,7 +84,7 @@
|
|||
#:minimal-variant [minimal-variant #f])
|
||||
(unless (complete-path? dir)
|
||||
(error 'vbox-vm "need a complete path for #:dir"))
|
||||
(vm host user dir name init-snapshot installed-snapshot minimal-variant))
|
||||
(vm name host user dir env init-snapshot installed-snapshot minimal-variant))
|
||||
|
||||
;; The build steps:
|
||||
(define all-steps-in-order
|
||||
|
|
@ -147,7 +149,8 @@
|
|||
;; "success/P.txt" records success;
|
||||
;; "install/P.txt" records installation;
|
||||
;; "deps/P.txt" records dependency-checking failure;
|
||||
;; "min-fail/P.txt" records failure on minimal-host attempt
|
||||
;; "test/P.txt" records `raco test` failure;
|
||||
;; "min-fail/P.txt" records failure on minimal-host attempt;
|
||||
;; * pkgs/P.orig-CHECKSUM matching archived catalog
|
||||
;; + fail/P.txt
|
||||
;; => up-to-date and failed;
|
||||
|
|
@ -167,6 +170,7 @@
|
|||
;; 'success-log --- #f or relative path
|
||||
;; 'failure-log --- #f or relative path
|
||||
;; 'dep-failure-log --- #f or relative path
|
||||
;; 'test-failure-log --- #f or relative path
|
||||
;; 'min-failure-log --- #f or relative path
|
||||
;; 'docs --- list of one of
|
||||
;; * (docs/none name)
|
||||
|
|
@ -205,6 +209,9 @@
|
|||
;; at the beginning if you know they're already done, and
|
||||
;; you can skip tests at the end if you don't want them:
|
||||
#:steps [steps (steps-in 'download 'summary)]
|
||||
|
||||
;; Run tests?
|
||||
#:run-tests? [run-tests? #t]
|
||||
|
||||
;; Omit specified packages from the summary:
|
||||
#:summary-omit-pkgs [summary-omit-pkgs null]
|
||||
|
|
@ -252,6 +259,7 @@
|
|||
(define success-dir (build-path built-dir "success"))
|
||||
(define install-success-dir (build-path built-dir "install"))
|
||||
(define deps-fail-dir (build-path built-dir "deps"))
|
||||
(define test-fail-dir (build-path built-dir "test"))
|
||||
|
||||
(define dumpster-dir (build-path work-dir "dumpster"))
|
||||
(define dumpster-pkgs-dir (build-path dumpster-dir "pkgs/"))
|
||||
|
|
@ -281,8 +289,10 @@
|
|||
(define (vm-remote vm)
|
||||
(remote #:host (vm-host vm)
|
||||
#:user (vm-user vm)
|
||||
#:env (list (cons "PLTUSERHOME"
|
||||
(~a (vm-dir vm) "/user")))
|
||||
#:env (append
|
||||
(vm-env vm)
|
||||
(list (cons "PLTUSERHOME"
|
||||
(~a (vm-dir vm) "/user"))))
|
||||
#:timeout timeout
|
||||
#:remote-tunnels (list (cons server-port server-port))))
|
||||
|
||||
|
|
@ -460,6 +470,7 @@
|
|||
(define (pkg-zip-checksum-file pkg) (build-path built-pkgs-dir (~a pkg ".zip.CHECKSUM")))
|
||||
(define (pkg-failure-dest pkg #:minimal? [min? #f])
|
||||
(build-path (if min? min-fail-dir fail-dir) (txt pkg)))
|
||||
(define (pkg-test-failure-dest pkg) (build-path test-fail-dir (txt pkg)))
|
||||
|
||||
(define failed-pkgs
|
||||
(for/set ([pkg (in-list all-pkg-names)]
|
||||
|
|
@ -641,6 +652,7 @@
|
|||
(make-directory* success-dir)
|
||||
(make-directory* install-success-dir)
|
||||
(make-directory* deps-fail-dir)
|
||||
(make-directory* test-fail-dir)
|
||||
|
||||
(make-directory* dumpster-pkgs-dir)
|
||||
(make-directory* dumpster-adds-dir)
|
||||
|
|
@ -656,9 +668,9 @@
|
|||
(lambda (o) (apply fprintf o fmt args))))
|
||||
(apply eprintf fmt args)
|
||||
#f)
|
||||
|
||||
;; Build one package or a group of packages:
|
||||
(define (build-pkgs vm pkgs #:minimal? [minimal? #f])
|
||||
|
||||
;; Print status and munge a list-of-list-of-packages:
|
||||
(define (status-pkgs pkgs action)
|
||||
(define flat-pkgs (flatten pkgs))
|
||||
;; one-pkg can be a list in the case of mutual dependencies:
|
||||
(define one-pkg (and (= 1 (length pkgs)) (car pkgs)))
|
||||
|
|
@ -668,12 +680,19 @@
|
|||
(if one-pkg
|
||||
(if (pair? one-pkg)
|
||||
(begin
|
||||
(status "Building mutually dependent packages:\n")
|
||||
(status "~a mutually dependent packages:\n" action)
|
||||
(show-list one-pkg))
|
||||
(status "Building ~a\n" one-pkg))
|
||||
(status "~a ~a\n" action one-pkg))
|
||||
(begin
|
||||
(status "Building packages together:\n")
|
||||
(status "~a packages together:\n" action)
|
||||
(show-list pkgs)))
|
||||
|
||||
(values flat-pkgs one-pkg pkgs-str))
|
||||
|
||||
;; Build one package or a group of packages:
|
||||
(define (build-pkgs vm pkgs #:minimal? [minimal? #f])
|
||||
(define-values (flat-pkgs one-pkg pkgs-str)
|
||||
(status-pkgs pkgs "Building"))
|
||||
|
||||
(define failure-dest (and one-pkg
|
||||
(pkg-failure-dest (car flat-pkgs) #:minimal? minimal?)))
|
||||
|
|
@ -751,7 +770,7 @@
|
|||
(when (and ok? one-pkg (not deps-ok?))
|
||||
;; Copy dependency-failure log for other packages in the group:
|
||||
(for ([pkg (in-list (cdr flat-pkgs))])
|
||||
(copy-file install-success-dest
|
||||
(copy-file deps-failure-dest
|
||||
(pkg-deps-failure-dest pkg)
|
||||
#t)))
|
||||
(define doc-ok?
|
||||
|
|
@ -783,6 +802,8 @@
|
|||
(delete-file (pkg-failure-dest pkg #:minimal? #t)))
|
||||
(when (and deps-ok? (file-exists? (pkg-deps-failure-dest pkg)))
|
||||
(delete-file (pkg-deps-failure-dest pkg)))
|
||||
(when (file-exists? (pkg-test-failure-dest pkg))
|
||||
(delete-file (pkg-test-failure-dest pkg)))
|
||||
(scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip"))
|
||||
built-pkgs-dir)
|
||||
(scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip.CHECKSUM"))
|
||||
|
|
@ -824,8 +845,49 @@
|
|||
ok?)
|
||||
(lambda ()
|
||||
(stop-vbox-vm (vm-name vm) #:save-state? #f))))
|
||||
|
||||
;; Test one package or a group of packages:
|
||||
(define (test-pkgs vm pkgs)
|
||||
;; If we get interrupted or something goes wrong here, we may
|
||||
;; leave a package in a built-but-not-tested state. That will
|
||||
;; look like the tests succeeded, so at least we don't
|
||||
;; improperly blame a package.
|
||||
(define-values (flat-pkgs one-pkg pkgs-str)
|
||||
(status-pkgs pkgs "Testing"))
|
||||
|
||||
;; Build a group of packages, recurring on smaller groups
|
||||
(define test-failure-dest (pkg-test-failure-dest (car flat-pkgs)))
|
||||
|
||||
(restore-vbox-snapshot (vm-name vm) (vm-installed-snapshot vm))
|
||||
(dynamic-wind
|
||||
(lambda () (start-vbox-vm (vm-name vm) #:max-vms (length vms)))
|
||||
(lambda ()
|
||||
(define rt (vm-remote vm))
|
||||
(make-sure-remote-is-ready rt)
|
||||
(define test-ok?
|
||||
(ssh rt (cd-racket vm)
|
||||
" && bin/raco pkg install -u --auto " pkgs-str
|
||||
" && bin/raco test --drdr --package " pkgs-str
|
||||
#:mode 'result
|
||||
#:failure-log test-failure-dest))
|
||||
|
||||
(cond
|
||||
[test-ok?
|
||||
(for ([pkg (in-list flat-pkgs)])
|
||||
(when (file-exists? (pkg-test-failure-dest pkg))
|
||||
(delete-file (pkg-test-failure-dest pkg))))]
|
||||
[else
|
||||
(when one-pkg
|
||||
;; Copy test-failure log for other packages in the group:
|
||||
(for ([pkg (in-list (cdr flat-pkgs))])
|
||||
(copy-file test-failure-dest
|
||||
(pkg-test-failure-dest pkg)
|
||||
#t)))
|
||||
(substatus "*** test failed ***\n")])
|
||||
test-ok?)
|
||||
(lambda ()
|
||||
(stop-vbox-vm (vm-name vm) #:save-state? #f))))
|
||||
|
||||
;; Build and test a group of packages, recurring on smaller groups
|
||||
;; if the big group fails:
|
||||
(define (build-pkg-set vm pkgs)
|
||||
(define len (length pkgs))
|
||||
|
|
@ -842,6 +904,9 @@
|
|||
;; with the non-minimal variant:
|
||||
(and has-minimal?
|
||||
(build-pkgs vm pkgs #:minimal? #f)))))
|
||||
(when (and ok? run-tests?)
|
||||
;; Testing always uses the non-minimal variant:
|
||||
(test-pkgs vm pkgs))
|
||||
(flush-chunk-output)
|
||||
(unless (or ok? (= 1 len))
|
||||
(define part (min (quotient len 2)
|
||||
|
|
@ -887,7 +952,11 @@
|
|||
(define t (thread/chunk-output
|
||||
(lambda ()
|
||||
(break-enabled #t)
|
||||
(status "Sending to ~a:\n" (vm-name vm))
|
||||
(status "Sending to ~a~a:\n"
|
||||
(vm-name vm)
|
||||
(if (vm-minimal-variant vm)
|
||||
(~a " / " (vm-name (vm-minimal-variant vm)))
|
||||
""))
|
||||
(show-list pkgs)
|
||||
(flush-chunk-output)
|
||||
(build-pkg-set vm pkgs)
|
||||
|
|
@ -1181,18 +1250,15 @@
|
|||
[(and succeeded? (not failed?)) 'success]
|
||||
[(and succeeded? failed?) 'confusion]
|
||||
[else 'unknown]))
|
||||
(define dep-status
|
||||
(define (more-status dir)
|
||||
(if (eq? status 'success)
|
||||
(if (file-exists? (build-path deps-fail-dir (txt pkg)))
|
||||
'failure
|
||||
'success)
|
||||
'unknown))
|
||||
(define min-status
|
||||
(if (eq? status 'success)
|
||||
(if (file-exists? (build-path min-fail-dir (txt pkg)))
|
||||
(if (file-exists? (build-path dir (txt pkg)))
|
||||
'failure
|
||||
'success)
|
||||
'unknown))
|
||||
(define dep-status (more-status deps-fail-dir))
|
||||
(define test-status (more-status test-fail-dir))
|
||||
(define min-status (more-status min-fail-dir))
|
||||
(define adds (let ([adds-file (if (eq? status 'success)
|
||||
(pkg-adds-file pkg)
|
||||
(build-path dumpster-adds-dir (format "~a-adds.rktd" pkg)))])
|
||||
|
|
@ -1216,6 +1282,8 @@
|
|||
(path->relative (pkg-failure-dest pkg)))
|
||||
'dep-failure-log (and (eq? dep-status 'failure)
|
||||
(path->relative (build-path deps-fail-dir (txt pkg))))
|
||||
'test-failure-log (and (eq? test-status 'failure)
|
||||
(path->relative (build-path test-fail-dir (txt pkg))))
|
||||
'min-failure-log (and (eq? min-status 'failure)
|
||||
(path->relative (build-path min-fail-dir (txt pkg))))
|
||||
'docs (for/list ([doc (in-list docs)])
|
||||
|
|
|
|||
|
|
@ -38,18 +38,15 @@
|
|||
[(and succeeded? (not failed?)) 'success]
|
||||
[(and succeeded? failed?) 'confusion]
|
||||
[else 'unknown]))
|
||||
(define dep-status
|
||||
(define (more-status key)
|
||||
(if (eq? status 'success)
|
||||
(if (hash-ref ht 'dep-failure-log)
|
||||
'failure
|
||||
'success)
|
||||
'unknown))
|
||||
(define min-status
|
||||
(if (eq? status 'success)
|
||||
(if (hash-ref ht 'min-failure-log)
|
||||
(if (hash-ref ht key)
|
||||
'failure
|
||||
'success)
|
||||
'unknown))
|
||||
(define dep-status (more-status 'dep-failure-log))
|
||||
(define test-status (more-status 'test-failure-log))
|
||||
(define min-status (more-status 'min-failure-log))
|
||||
(define docs (hash-ref ht 'docs))
|
||||
(define author (hash-ref ht 'author))
|
||||
(define conflicts-log (hash-ref ht 'conflicts-log))
|
||||
|
|
@ -81,35 +78,50 @@
|
|||
(td class: (case status
|
||||
[(failure confusion) "stop"]
|
||||
[(success)
|
||||
(case dep-status
|
||||
[(failure) "yield"]
|
||||
[else
|
||||
(case min-status
|
||||
[(failure) "ok"]
|
||||
[else "go"])])]
|
||||
(cond
|
||||
[(eq? dep-status 'failure)
|
||||
"brake"]
|
||||
[(eq? test-status 'failure)
|
||||
"yield"]
|
||||
[(eq? min-status 'failure)
|
||||
"ok"]
|
||||
[else "go"])]
|
||||
[else "unknown"])
|
||||
(case status
|
||||
[(failure)
|
||||
(a href: (hash-ref ht 'failure-log)
|
||||
"install fails")]
|
||||
[(success)
|
||||
(list
|
||||
(a href: (hash-ref ht 'success-log)
|
||||
"install succeeds")
|
||||
(case dep-status
|
||||
[(failure)
|
||||
(list
|
||||
" with "
|
||||
(a href: (hash-ref ht 'dep-failure-log)
|
||||
"dependency problems"))])
|
||||
(case min-status
|
||||
[(failure)
|
||||
(list
|
||||
(if (eq? dep-status 'failure)
|
||||
" and with "
|
||||
" with ")
|
||||
(a href: (hash-ref ht 'min-failure-log)
|
||||
"extra system dependencies"))]))]
|
||||
(define results
|
||||
(append
|
||||
(list
|
||||
(a href: (hash-ref ht 'success-log)
|
||||
"install succeeds"))
|
||||
(case dep-status
|
||||
[(failure)
|
||||
(list
|
||||
(a href: (hash-ref ht 'dep-failure-log)
|
||||
"dependency problems"))]
|
||||
[else null])
|
||||
(case test-status
|
||||
[(failure)
|
||||
(list
|
||||
(a href: (hash-ref ht 'test-failure-log)
|
||||
"test failures"))]
|
||||
[else null])
|
||||
(case min-status
|
||||
[(failure)
|
||||
(list
|
||||
(a href: (hash-ref ht 'min-failure-log)
|
||||
"extra system dependencies"))]
|
||||
[else null])))
|
||||
(if (= 1 (length results))
|
||||
results
|
||||
(list* (car results)
|
||||
" with "
|
||||
(add-between
|
||||
(cdr results)
|
||||
" and with ")))]
|
||||
[(confusion)
|
||||
(list
|
||||
"install both "
|
||||
|
|
@ -132,8 +144,9 @@
|
|||
(style/inline @~a|{
|
||||
.go { background-color: #ccffcc }
|
||||
.ok { background-color: #ccffff }
|
||||
.stop { background-color: #ffcccc }
|
||||
.yield { background-color: #ffffcc }
|
||||
.brake { background-color: #ffeecc }
|
||||
.stop { background-color: #ffcccc }
|
||||
.author { font-size: small; font-weight: normal; }
|
||||
.annotation { font-size: small }
|
||||
}|))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user