From e381192e6eadbad7e050c5cc740ca38d31dac8e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Oct 2014 19:39:29 -0600 Subject: [PATCH] meta/pkg-build: run `raco test --drdr` for each package --- pkgs/plt-services/meta/pkg-build/main.rkt | 112 +++++++++++++++---- pkgs/plt-services/meta/pkg-build/summary.rkt | 77 +++++++------ 2 files changed, 135 insertions(+), 54 deletions(-) diff --git a/pkgs/plt-services/meta/pkg-build/main.rkt b/pkgs/plt-services/meta/pkg-build/main.rkt index a9e3522a03..f4e0595c55 100644 --- a/pkgs/plt-services/meta/pkg-build/main.rkt +++ b/pkgs/plt-services/meta/pkg-build/main.rkt @@ -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 ) ...) + #: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)]) diff --git a/pkgs/plt-services/meta/pkg-build/summary.rkt b/pkgs/plt-services/meta/pkg-build/summary.rkt index fa348760c9..14e38d9d34 100644 --- a/pkgs/plt-services/meta/pkg-build/summary.rkt +++ b/pkgs/plt-services/meta/pkg-build/summary.rkt @@ -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 } }|))