- Removing planet package installation

- Fixing responsible for DrDr imagined code
- Code reorganization
- Handling environment variables in hash-table and with env
- Removing futures-build
- Cleaning up committer email content

svn: r18434
This commit is contained in:
Jay McCarthy 2010-03-02 20:46:18 +00:00
parent b020c8dc21
commit a6214b7731
12 changed files with 202 additions and 200 deletions

View File

@ -6,7 +6,7 @@
"notify.ss"
"cache.ss"
"dirstruct.ss"
"run-collect.ss"
"status.ss"
"path-utils.ss"
"rendering.ss")
(provide (all-from-out "rendering.ss"))
@ -90,6 +90,14 @@
(define responsible-ht/c
(hash/c string? (hash/c symbol? (listof path?))))
(define (responsible-ht->status-ht diff)
(for/hash ([id (in-list responsible-ht-severity)])
(define id-l
(for*/list ([(_ ht) (in-hash diff)]
[f (in-list (hash-ref ht id empty))])
f))
(values id (remove-duplicates id-l))))
(provide/contract
[rendering->responsible-ht
(exact-positive-integer? rendering? . -> . responsible-ht/c)]
@ -160,21 +168,26 @@
(list
(format "~a:" committer)
(format "You are receiving this email because the DrDr test of revision ~a (which you committed) contained a NEW condition that may need inspecting." cur-rev)
(for*/list ([(r ht) (in-hash diff)]
[(id files) (in-hash ht)]
[f (in-list files)])
(format "\t~a (~a)" (path->url f) id))
(let ([diff-smash (responsible-ht->status-ht diff)])
(for/list ([(id paths) (in-hash diff-smash)]
#:when (not (symbol=? id 'changes)))
(if (empty? paths)
empty
(list (format "\t~a" id)
(for/list ([f (in-list paths)])
(format "\t\t~a" (path->url f)))
""))))
"")
empty)
(for/list ([r (in-list responsibles)])
(list (format "~a:" r)
"You are receiving this email because a file you are responsible for has a condition that may need inspecting."
(for/list ([(id files) (in-hash (hash-ref responsible-ht r))]
#:when (not (symbol=? id 'changes)))
(list (format "\t~a:" id)
(for/list ([f (in-list files)])
(format "\t\t~a" (path->url f)))
""))
(list* (format "~a:" r)
"You are receiving this email because a file you are responsible for has a condition that may need inspecting."
(for/list ([(id files) (in-hash (hash-ref responsible-ht r))]
#:when (not (symbol=? id 'changes)))
(list (format "\t~a:" id)
(for/list ([f (in-list files)])
(format "\t\t~a" (path->url f)))
""))
""))))))
(send-mail-message "drdr"
@ -248,10 +261,10 @@
#f))
(define responsible
(or (svn-property-value/root (trunk-path log-pth) plt:responsible)
(and (regexp-match #rx"^/planet" (path->string* log-pth))
(and (regexp-match #rx"/planet/" (path->string* log-pth))
"jay")
; XXX maybe mflatt, eli, or tewk
(and (regexp-match #rx"^/src" (path->string* log-pth))
(and (regexp-match #rx"/src/" (path->string* log-pth))
"jay")
"unknown"))
(define lc

View File

@ -1,7 +1,6 @@
#lang scheme
(require "run-collect.ss"
"cache.ss"
(require "cache.ss"
"dirstruct.ss"
"svn.ss"
"monitor-svn.ss")

View File

@ -4,6 +4,9 @@
(define number-of-cpus
(make-parameter 1))
(define current-subprocess-timeout-seconds
(make-parameter (* 60 10)))
(define plt-directory
(make-parameter (build-path (current-directory))))
@ -81,6 +84,7 @@
(path-timing-log p))
(provide/contract
[current-subprocess-timeout-seconds (parameter/c exact-nonnegative-integer?)]
[number-of-cpus (parameter/c exact-nonnegative-integer?)]
[current-rev (parameter/c (or/c false/c exact-nonnegative-integer?))]
[previous-rev (parameter/c (or/c false/c exact-nonnegative-integer?))]

View File

@ -1,6 +1,5 @@
#lang scheme
(require "run-collect.ss"
"path-utils.ss"
(require "path-utils.ss"
"svn.ss")
(define (testable-file? pth)
@ -26,16 +25,11 @@
(regexp-split #rx" " s))]))
(define (path-timeout a-path)
(match
(with-handlers ([exn:fail? (lambda (x) #f)])
(string->number (svn-property-value/root a-path SVN-PROP:timeout)))
[#f
(current-subprocess-timeout-seconds)]
[(? number? n)
n]))
(with-handlers ([exn:fail? (lambda (x) #f)])
(string->number (svn-property-value/root a-path SVN-PROP:timeout))))
(provide/contract
[SVN-PROP:command-line string?]
[SVN-PROP:timeout string?]
[path-command-line (path-string? . -> . (or/c (listof string?) false/c))]
[path-timeout (path-string? . -> . exact-nonnegative-integer?)])
[path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))])

View File

@ -1,5 +1 @@
(("schematics" "schemeunit.plt" 2 10 #f)
("cce" "scheme.plt" 4 1 #f)
("lizorkin" "sxml.plt" 2 1 #f)
("jaymccarthy" "sqlite.plt" 4 5 #f)
("cobbe" "views.plt" 1 1 #f))
()

View File

@ -6,10 +6,21 @@
"run-collect.ss"
"cache.ss"
"dirstruct.ss"
"replay.ss"
"notify.ss"
"path-utils.ss"
"sema.ss"
"svn.ss")
(define current-env (make-parameter (make-immutable-hash empty)))
(define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...)
(parameterize ([current-env
(for/fold ([env (current-env)])
([k (in-list (list env-expr ...))]
[v (in-list (list val-expr ...))])
(hash-set env k v))])
expr ...))
(define (build-revision rev)
(define rev-dir (revision-dir rev))
(define co-dir (revision-trunk-dir rev))
@ -27,50 +38,45 @@
(lambda ()
(notify! "Removing checkout directory: ~a" co-dir)
(safely-delete-directory co-dir)
; XXX Give it its own timeout
(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
(svn-checkout
(plt-repository) rev
(path->string co-dir)))))
(local [(define repo (plt-repository))
(define to-dir
(path->string co-dir))]
(notify! "Checking out ~a@~a into ~a"
repo rev to-dir)
(run/collect/wait/log
; XXX Give it its own timeout
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "svn-checkout")
(svn-path)
(list
"checkout"
"--quiet"
"-r" (number->string rev)
repo
to-dir)))))
;; Make the build directory
(make-directory* build-dir)
;; Run Configure, Make, Make Install
(parameterize ([current-directory build-dir])
(run/collect/wait/log
#:timeout (current-subprocess-timeout-seconds)
#:env (current-env)
(build-path log-dir "src" "build" "configure")
(path->string (build-path src-dir "configure")))
(parameterize ([current-subprocess-timeout-seconds (current-make-timeout-seconds)])
(run/collect/wait/log
(build-path log-dir "src" "build" "make")
(make-path) "-j" (number->string (number-of-cpus))))
(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
(run/collect/wait/log
(build-path log-dir "src" "build" "make-install")
(make-path) "-j" (number->string (number-of-cpus)) "install"))
#;(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
(run/collect/wait/log
(build-path log-dir "src" "build" "setup-plt-no-docs")
setup-plt-path "--no-docs"))
#;(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
(run/collect/wait/log
(build-path log-dir "src" "build" "setup-plt")
setup-plt-path)))
;; Test Futures
(make-directory* futures-build-dir)
;; Run Configure, Make, Test
(parameterize ([current-directory futures-build-dir])
(path->string (build-path src-dir "configure"))
empty)
(run/collect/wait/log
(build-path log-dir "src" "futures-build" "configure")
(path->string (build-path src-dir "configure")) "--enable-futures")
(parameterize ([current-subprocess-timeout-seconds (current-make-timeout-seconds)]
[current-directory (build-path futures-build-dir "mzscheme")])
(run/collect/wait/log
(build-path log-dir "src" "futures-build" "mzscheme" "make")
(make-path) "-j" (number->string (number-of-cpus)))
(run/collect/wait/log
(build-path log-dir "src" "futures-build" "mzscheme" "futures-startup-test")
(path->string (build-path futures-build-dir "mzscheme" "mzscheme3m")) "-e" "(printf \"startedup\n\")")
)))
#:timeout (current-make-timeout-seconds)
#:env (current-env)
(build-path log-dir "src" "build" "make")
(make-path)
(list "-j" (number->string (number-of-cpus))))
(run/collect/wait/log
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "src" "build" "make-install")
(make-path)
(list "-j" (number->string (number-of-cpus)) "install"))))
(define (call-with-temporary-directory thunk)
(define tempdir (symbol->string (gensym 'tmpdir)))
@ -85,10 +91,44 @@
(define-syntax-rule (with-temporary-directory e)
(call-with-temporary-directory (lambda () e)))
(define (semaphore-wait* sema how-many)
(unless (zero? how-many)
(semaphore-wait sema)
(semaphore-wait* sema (sub1 how-many))))
(define (with-running-program command args thunk)
(define-values (new-command new-args)
(command+args+env->command+args
#:env (current-env)
command args))
(define-values
(the-process stdout stdin stderr)
(apply subprocess
#f #;(current-error-port)
#f
#f #;(current-error-port)
new-command new-args))
; Die if this program does
(define parent
(current-thread))
(define waiter
(thread
(lambda ()
(subprocess-wait the-process)
(printf "Killing parent because wrapper is dead...~n")
(kill-thread parent))))
; Run without stdin
(close-output-port stdin)
(begin0
; Run the thunk
(thunk)
; Close the output ports
(close-input-port stdout)
(close-input-port stderr)
; Kill the guard
(kill-thread waiter)
; Kill the process
(subprocess-kill the-process #t)))
(define-runtime-path package-list "pkgs")
(define (planet-packages)
@ -133,7 +173,9 @@
(local [(define log-pth (trunk->log pth))]
(if (file-exists? log-pth)
(semaphore-post dir-sema)
(local [(define pth-timeout (path-timeout pth))
(local [(define pth-timeout
(or (path-timeout pth)
(current-subprocess-timeout-seconds)))
(define pth-cmd/general (path-command-line pth))
(define pth-cmd
(match pth-cmd/general
@ -153,17 +195,17 @@
(submit-job!
test-workers
(lambda ()
; XXX Maybe this should destroy the old home and copy in a new one
; Otherwise it is a source of randomness
(with-temporary-directory
(parameterize ([current-subprocess-timeout-seconds pth-timeout])
(apply run/collect/wait/log log-pth
"/usr/bin/env"
(format "DISPLAY=~a"
(format ":~a" (+ XSERVER-OFFSET (current-worker))))
(format "HOME=~a"
(home-dir (current-worker)))
(pth-cmd))))
(define l (pth-cmd))
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]
["HOME" (home-dir (current-worker))])
; XXX Maybe this should destroy the old home and copy in a new one
; Otherwise it is a source of randomness
(with-temporary-directory
(run/collect/wait/log log-pth
#:timeout pth-timeout
#:env (current-env)
(first l)
(rest l))))
(semaphore-post dir-sema)))
(semaphore-post dir-sema)))))))
files)
@ -174,26 +216,32 @@
(write-cache! dir-log (current-seconds))
(semaphore-post upper-sema)))))))
; Some setup
; XXX Give it its own timeout
(parameterize ([current-subprocess-timeout-seconds (current-make-install-timeout-seconds)])
(for ([pp (in-list (planet-packages))])
(match pp
[`(,auth ,pkg ,majn ,minn ,ver)
(define maj (number->string majn))
(define min (number->string minn))
(run/collect/wait/log
(build-path log-dir "planet" auth pkg maj min)
planet-path "install" auth pkg maj min)])))
(for ([pp (in-list (planet-packages))])
(match pp
[`(,auth ,pkg ,majn ,minn ,ver)
(define maj (number->string majn))
(define min (number->string minn))
(run/collect/wait/log
; XXX Give it its own timeout
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "planet" auth pkg maj min)
planet-path
(list "install" auth pkg maj min))]))
(run/collect/wait/log
#:timeout (current-subprocess-timeout-seconds)
#:env (current-env)
(build-path log-dir "src" "build" "set-browser.ss")
mzscheme-path "-t" (path->string* (build-path (drdr-directory) "set-browser.ss")))
mzscheme-path
(list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss"))))
; Make home directories
(cache/file/timestamp
(build-path rev-dir "homedir-dup")
(lambda ()
(notify! "Copying home directory for each worker")
(for ([i (in-range (number-of-cpus))])
(copy-directory/files (getenv "HOME") (home-dir i)))))
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") (home-dir i))))))
; And go
(notify! "Starting testing")
(test-directory collects-pth top-sema)
@ -204,33 +252,9 @@
(define (home-dir i)
(format "~a~a"
(getenv "HOME")
(hash-ref (current-env) "HOME")
i))
(define-syntax (with-env stx)
(syntax-case stx ()
[(_ ([env-expr val-expr] ...) expr ...)
(with-syntax ([(env-val ...) (generate-temporaries #'(env-expr ...))]
[(old-env-val ...) (generate-temporaries #'(env-expr ...))]
[(new-env-val ...) (generate-temporaries #'(env-expr ...))])
(syntax/loc stx
(local [(define env-val env-expr)
...
(define old-env-val (getenv env-val))
...
(define new-env-val val-expr)
...]
(dynamic-wind
(lambda ()
(putenv env-val new-env-val)
...)
(lambda ()
expr ...)
(lambda ()
(when old-env-val
(putenv env-val old-env-val))
...)))))]))
(define (recur-many i r f)
(if (zero? i)
(f)
@ -281,7 +305,7 @@
(safely-delete-directory (format "/tmp/.tX~a-lock" i))
(safely-delete-directory (build-path tmp-dir (format ".tX~a-lock" i)))
(with-running-program
(Xvfb-path) (list (format ":~a" i) "-screen" "0" "800x600x24")
(Xvfb-path) (list (format ":~a" i) "-screen" "0" "800x600x24" "-ac" "-br" "-bs" "-kb")
(lambda ()
(with-running-program
(fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init")

View File

@ -9,7 +9,7 @@
"cache.ss"
(except-in "dirstruct.ss"
revision-trunk-dir)
"run-collect.ss"
"status.ss"
"monitor-svn.ss"
"metadata.ss"
"formats.ss"

View File

@ -1,7 +1,7 @@
#lang scheme
(require "replay.ss"
"cache.ss"
"run-collect.ss")
"status.ss")
; XXX Rewrite to work with logs in dbm

View File

@ -4,8 +4,14 @@
"rewriting.ss"
"cache.ss")
(define current-subprocess-timeout-seconds
(make-parameter (* 60 10)))
(define (command+args+env->command+args
#:env env
cmd args)
(values "/usr/bin/env"
(append (for/list ([(k v) (in-hash env)])
(format "~a=~a" k v))
(list* cmd
args))))
(define (read-until-evt port-evt k)
(if port-evt
@ -16,19 +22,26 @@
(k bs))))
never-evt))
(define (run/collect/wait command . args)
(define (run/collect/wait
#:env env
#:timeout timeout
command args)
(define start-time
(current-inexact-milliseconds))
; Run the command
(define-values (new-command new-args)
(command+args+env->command+args
#:env env
command args))
(define command-line
(list* command args))
(define-values
(the-process stdout stdin stderr)
(apply subprocess
#f #f #f
command
args))
new-command
new-args))
(notify! "Running: ~a ~S" command args)
@ -39,7 +52,7 @@
(local
[(define the-alarm
(alarm-evt (+ (current-inexact-milliseconds)
(* 1000 (current-subprocess-timeout-seconds)))))
(* 1000 timeout))))
(define (slurp-output-evt loop stdout stderr log)
(choice-evt
(read-until-evt stdout
@ -84,55 +97,28 @@
final-status))
(define (run/collect/wait/log log-path . rcw-args)
(define (run/collect/wait/log log-path command
#:timeout timeout
#:env env
args)
(define ran? #f)
(cache/file
log-path
(lambda ()
(set! ran? #t)
(rewrite-status
(apply run/collect/wait rcw-args))))
(run/collect/wait
#:timeout timeout
#:env env
command args))))
ran?)
(define (with-running-program command args thunk)
(define-values
(the-process stdout stdin stderr)
(apply subprocess
(current-error-port) #f
(current-error-port)
command
args))
; Die if this program does
(define parent
(current-thread))
(define waiter
(thread
(lambda ()
(subprocess-wait the-process)
(printf "Killing parent because wrapper is dead...~n")
(kill-thread parent))))
; Run without stdin
(close-output-port stdin)
(begin0
; Run the thunk
(thunk)
; Close the output ports
#;(close-input-port stdout)
#;(close-input-port stderr)
; Kill the guard
(kill-thread waiter)
; Kill the process
(subprocess-kill the-process #t)))
(provide
(all-from-out "status.ss"))
(provide/contract
[current-subprocess-timeout-seconds (parameter/c exact-nonnegative-integer?)]
[with-running-program (string? (listof string?) (-> any) . -> . any)]
[run/collect/wait ((string?) () #:rest (listof string?) . ->* . status?)]
[run/collect/wait/log ((path-string? string?) () #:rest (listof string?) . ->* . boolean?)])
[command+args+env->command+args
(string? (listof string?) #:env (hash/c string? string?) . -> . (values string? (listof string?)))]
[run/collect/wait/log
(path-string? string?
#:env (hash/c string? string?)
#:timeout exact-nonnegative-integer?
(listof string?)
. -> . boolean?)])

View File

@ -0,0 +1,9 @@
#lang scheme
(define (semaphore-wait* sema how-many)
(unless (zero? how-many)
(semaphore-wait sema)
(semaphore-wait* sema (sub1 how-many))))
(provide/contract
[semaphore-wait* (semaphore? exact-nonnegative-integer? . -> . void)])

View File

@ -1,7 +1,5 @@
#lang scheme
(require xml
"run-collect.ss"
"replay.ss"
"notify.ss"
(prefix-in ffi: (planet jaymccarthy/svn-prop)))
@ -180,25 +178,4 @@
[changes (listof svn-change?)])]
[struct svn-change
([action symbol?]
[path path-string?])])
(define (svn-checkout repo rev to-dir)
(notify! "Checking out ~a@~a into ~a"
repo rev to-dir)
(local
[(define svn-status
(run/collect/wait
(svn-path)
"checkout"
"--quiet"
"-r" (number->string rev)
repo
to-dir))]
(unless (and (exit? svn-status)
(zero? (exit-code svn-status)))
(printf "Replaying SVN output:~n")
(replay-status svn-status)
(error 'svn-checkout "Error on checkout!"))))
(provide/contract
[svn-checkout (string? exact-nonnegative-integer? string? . -> . void)])
[path path-string?])])

View File

@ -5,6 +5,7 @@
"notify.ss"
"path-utils.ss"
"dirstruct.ss"
"sema.ss"
"cache.ss")
(define test-workers (make-job-queue (number-of-cpus)))
@ -83,7 +84,6 @@
(find-files (revision-log-dir start-revision)
empty))
(for ([i (in-range how-many-files)])
(semaphore-wait count-sema))
(semaphore-wait* count-sema how-many-files)
(stop-job-queue! test-workers)