317 lines
13 KiB
Scheme
317 lines
13 KiB
Scheme
#lang scheme
|
|
(require scheme/file
|
|
scheme/runtime-path
|
|
(planet jaymccarthy/job-queue)
|
|
"metadata.ss"
|
|
"run-collect.ss"
|
|
"cache.ss"
|
|
"dirstruct.ss"
|
|
"replay.ss"
|
|
"notify.ss"
|
|
"path-utils.ss"
|
|
"sema.ss"
|
|
"scm.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))
|
|
(define src-dir (build-path co-dir "src"))
|
|
(define build-dir (build-path src-dir "build"))
|
|
(define futures-build-dir (build-path src-dir "futures-build"))
|
|
(define log-dir (revision-log-dir rev))
|
|
(define trunk-dir
|
|
(revision-trunk-dir rev))
|
|
(define setup-plt-path
|
|
(path->string (build-path trunk-dir "bin" "setup-plt")))
|
|
;; Checkout the repository revision
|
|
(cache/file/timestamp
|
|
(build-path rev-dir "checkout-done")
|
|
(lambda ()
|
|
(notify! "Removing checkout directory: ~a" co-dir)
|
|
(safely-delete-directory 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)
|
|
(scm-export-repo 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"))
|
|
empty)
|
|
(run/collect/wait/log
|
|
#: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)))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(make-directory* tempdir))
|
|
(lambda ()
|
|
(parameterize ([current-directory tempdir])
|
|
(thunk)))
|
|
(lambda ()
|
|
(delete-directory/files tempdir))))
|
|
(define-syntax-rule (with-temporary-directory e)
|
|
(call-with-temporary-directory (lambda () e)))
|
|
|
|
(define (call-with-temporary-home-directory thunk)
|
|
(define new-dir (make-temporary-file "home~a" 'directory (current-temporary-directory)))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(with-handlers ([exn:fail? void])
|
|
(copy-directory/files (hash-ref (current-env) "HOME") new-dir)))
|
|
(lambda ()
|
|
(with-env (["HOME" (path->string new-dir)])
|
|
(thunk)))
|
|
(lambda ()
|
|
(delete-directory/files new-dir))))
|
|
(define-syntax-rule (with-temporary-home-directory e)
|
|
(call-with-temporary-home-directory (lambda () e)))
|
|
|
|
(define (with-running-program command args thunk)
|
|
(if command
|
|
(local [(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)))
|
|
(thunk)))
|
|
|
|
(define-runtime-path package-list "pkgs")
|
|
(define (planet-packages)
|
|
(file->value package-list))
|
|
|
|
(define (test-revision rev)
|
|
(define rev-dir (revision-dir rev))
|
|
(define trunk-dir
|
|
(revision-trunk-dir rev))
|
|
(define log-dir
|
|
(revision-log-dir rev))
|
|
(define trunk->log
|
|
(rebase-path trunk-dir log-dir))
|
|
(define racket-path
|
|
(path->string (build-path trunk-dir "bin" "racket")))
|
|
; XXX fix
|
|
(define mzc-path
|
|
(path->string (build-path trunk-dir "bin" "mzc")))
|
|
(define gracket-text-path
|
|
(path->string (build-path trunk-dir "bin" "gracket-text")))
|
|
(define gracket-path
|
|
(path->string (build-path trunk-dir "bin" "gracket")))
|
|
; XXX fix
|
|
(define planet-path
|
|
(path->string (build-path trunk-dir "bin" "planet")))
|
|
(define collects-pth
|
|
(build-path trunk-dir "collects"))
|
|
(define test-workers (make-job-queue (number-of-cpus)))
|
|
(define top-sema (make-semaphore 0))
|
|
(define (test-directory dir-pth upper-sema)
|
|
(define dir-log (build-path (trunk->log dir-pth) ".index.test"))
|
|
(if (read-cache* dir-log)
|
|
(semaphore-post upper-sema)
|
|
(begin
|
|
(notify! "Testing in ~S" dir-pth)
|
|
(local [(define files (directory-list* dir-pth))
|
|
(define how-many (length files))
|
|
(define dir-sema (make-semaphore 0))]
|
|
(for-each (lambda (sub-pth)
|
|
(define pth (build-path dir-pth sub-pth))
|
|
(define directory? (directory-exists? pth))
|
|
(if directory?
|
|
(test-directory pth dir-sema)
|
|
(local [(define log-pth (trunk->log pth))]
|
|
(if (file-exists? log-pth)
|
|
(semaphore-post dir-sema)
|
|
(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
|
|
[#f
|
|
#f]
|
|
[(list-rest (or 'mzscheme 'racket) rst)
|
|
(lambda () (list* racket-path rst))]
|
|
[(list-rest 'mzc rst)
|
|
(lambda () (list* mzc-path rst))]
|
|
[(list-rest (or 'mred 'mred-text
|
|
'gracket 'gracket-text)
|
|
rst)
|
|
(if (on-unix?)
|
|
(lambda ()
|
|
(list* gracket-text-path "-display" (format ":~a" (+ XSERVER-OFFSET (current-worker))) rst))
|
|
#f)]
|
|
[_
|
|
#f]))]
|
|
(if pth-cmd
|
|
(submit-job!
|
|
test-workers
|
|
(lambda ()
|
|
(define l (pth-cmd))
|
|
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))])
|
|
(with-temporary-home-directory
|
|
(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)
|
|
(thread
|
|
(lambda ()
|
|
(semaphore-wait* dir-sema how-many)
|
|
(notify! "Done with dir: ~a" dir-pth)
|
|
(write-cache! dir-log (current-seconds))
|
|
(semaphore-post upper-sema)))))))
|
|
; Some setup
|
|
(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")
|
|
racket-path
|
|
(list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss"))))
|
|
; And go
|
|
(notify! "Starting testing")
|
|
(test-directory collects-pth top-sema)
|
|
(notify! "All testing scheduled... waiting for completion")
|
|
(semaphore-wait top-sema)
|
|
(notify! "Stopping testing")
|
|
(stop-job-queue! test-workers))
|
|
|
|
(define (recur-many i r f)
|
|
(if (zero? i)
|
|
(f)
|
|
(r (sub1 i) (lambda ()
|
|
(recur-many (sub1 i) r f)))))
|
|
|
|
(define XSERVER-OFFSET 20)
|
|
|
|
(define (integrate-revision rev)
|
|
(define test-dir
|
|
(build-path (revision-dir rev) "test"))
|
|
(define planet-dir
|
|
(build-path test-dir "planet"))
|
|
(define home-dir
|
|
(build-path test-dir "home"))
|
|
(define tmp-dir
|
|
(build-path test-dir "tmp"))
|
|
(define trunk-dir
|
|
(revision-trunk-dir rev))
|
|
(cache/file/timestamp
|
|
(build-path (revision-dir rev) "integrated")
|
|
(lambda ()
|
|
(make-directory* test-dir)
|
|
(make-directory* planet-dir)
|
|
(make-directory* home-dir)
|
|
(make-directory* tmp-dir)
|
|
; We are running inside of a test directory so that random files are stored there
|
|
(parameterize ([current-directory test-dir]
|
|
[current-temporary-directory tmp-dir]
|
|
[current-rev rev])
|
|
(with-env (["PLTSTDERR" "error"]
|
|
["GIT_DIR" (path->string (plt-repository))]
|
|
["TMPDIR" (path->string tmp-dir)]
|
|
["PATH"
|
|
(format "~a:~a"
|
|
(path->string (build-path trunk-dir "bin"))
|
|
(getenv "PATH"))]
|
|
["PLTPLANETDIR" (path->string planet-dir)]
|
|
["HOME" (path->string home-dir)])
|
|
(unless (read-cache* (revision-commit-msg rev))
|
|
(write-cache! (revision-commit-msg rev)
|
|
(get-scm-commit-msg rev (plt-repository))))
|
|
(when (build?)
|
|
(build-revision rev))
|
|
(recur-many (number-of-cpus)
|
|
(lambda (j inner)
|
|
(define i (+ j XSERVER-OFFSET))
|
|
(notify! "Starting X server #~a" i)
|
|
(safely-delete-directory (format "/tmp/.X~a-lock" i))
|
|
(safely-delete-directory (build-path tmp-dir (format ".X~a-lock" i)))
|
|
(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" "-ac" "-br" "-bs" "-kb")
|
|
(lambda ()
|
|
(with-running-program
|
|
(fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init")
|
|
inner))))
|
|
(lambda ()
|
|
(test-revision rev)))))
|
|
; Remove the test directory
|
|
(safely-delete-directory test-dir))))
|
|
|
|
(provide/contract
|
|
[integrate-revision (exact-nonnegative-integer? . -> . void)]) |