From f9ca17aa2bbb91f2e3775e2fce9cd4b19e91e529 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 16:18:16 -0600 Subject: [PATCH] Getting DrDr at home ready --- collects/meta/drdr/at-home.ss | 66 ++++++++++++++++++++++++++ collects/meta/drdr/config.ss | 1 + collects/meta/drdr/dirstruct.ss | 9 ++-- collects/meta/drdr/metadata.ss | 1 + collects/meta/drdr/plt-build.ss | 79 ++++++++++++++++--------------- collects/meta/drdr/run-collect.ss | 2 +- 6 files changed, 116 insertions(+), 42 deletions(-) create mode 100644 collects/meta/drdr/at-home.ss diff --git a/collects/meta/drdr/at-home.ss b/collects/meta/drdr/at-home.ss new file mode 100644 index 0000000000..ca34edc76c --- /dev/null +++ b/collects/meta/drdr/at-home.ss @@ -0,0 +1,66 @@ +#lang racket +(require racket/runtime-path + "scm.ss" + "cache.ss" + "metadata.ss" + "plt-build.ss" + "notify.ss" + "path-utils.ss" + "dirstruct.ss") + +(command-line #:program "drdr-at-home" + #:once-each + [("-j" "--jobs") jobs "How many processes to run simultaneously" (number-of-cpus (string->number jobs))] + ["--no-build" "Do not build, just test" (build? #f)]) + +; Find paths we need +(define (path->string^ p) + (and p (path->string p))) + +(git-path (path->string^ (find-executable-path "git"))) +(Xvfb-path #f #;(path->string^ (find-executable-path "Xvfb"))) +(fluxbox-path #f #;(path->string^ (find-executable-path "fluxbox"))) + +; Find where we are +(define-runtime-path here ".") +(drdr-directory here) +(define this-rev-dir (build-path here 'up 'up 'up)) + +; Setup directories that DrDr needs +(define tmp-plt (make-temporary-file "plt~a" 'directory)) +(plt-directory tmp-plt) +(for ([d (in-list (list "builds" "future-builds" "data"))]) + (make-directory* (build-path tmp-plt d))) + +(make-file-or-directory-link this-rev-dir (build-path tmp-plt "repo")) +(make-file-or-directory-link this-rev-dir (build-path tmp-plt "plt")) + +; Make up a revision and link it in +(define fake-rev 50) +(define fake-trunk (revision-trunk-dir fake-rev)) +(make-parent-directory fake-trunk) +(make-file-or-directory-link this-rev-dir fake-trunk) +(write-cache! (revision-commit-msg fake-rev) + (make-git-push fake-rev "you!" empty)) + +; Override the props file +(hash-set! props-cache fake-rev + (dynamic-require `(file ,(path->string (build-path this-rev-dir "collects" "meta" "props"))) + 'get-prop)) + +; Setup the logger +(void + (thread + (lambda () + (define recv (make-log-receiver (current-logger) 'info)) + (let loop () + (match-define (vector level msg val) (sync recv)) + (display msg) (newline) + (loop))))) + +; Do it! +(notify! "Starting DrDr at home") +(integrate-revision fake-rev) + +; Clean up +(delete-directory/files tmp-plt) \ No newline at end of file diff --git a/collects/meta/drdr/config.ss b/collects/meta/drdr/config.ss index 02f1ec3028..ab7381e6f5 100644 --- a/collects/meta/drdr/config.ss +++ b/collects/meta/drdr/config.ss @@ -9,6 +9,7 @@ (drdr-directory "/opt/svn/drdr") (git-path "/usr/bin/git") (Xvfb-path "/usr/bin/Xvfb") +(fluxbox-path "/usr/bin/fluxbox")) (current-make-install-timeout-seconds (* 90 60)) (current-make-timeout-seconds (* 90 60)) (current-subprocess-timeout-seconds 90) diff --git a/collects/meta/drdr/dirstruct.ss b/collects/meta/drdr/dirstruct.ss index dbd1767c53..fe91d0d714 100644 --- a/collects/meta/drdr/dirstruct.ss +++ b/collects/meta/drdr/dirstruct.ss @@ -83,6 +83,8 @@ (define (path-timing-png-prefix p) (path-timing-log p)) +(define build? (make-parameter #t)) + (provide/contract [current-subprocess-timeout-seconds (parameter/c exact-nonnegative-integer?)] [number-of-cpus (parameter/c exact-nonnegative-integer?)] @@ -93,9 +95,10 @@ [plt-data-directory (-> path?)] [plt-future-build-directory (-> path?)] [drdr-directory (parameter/c path-string?)] - [make-path (parameter/c string?)] - [Xvfb-path (parameter/c string?)] - [fluxbox-path (parameter/c string?)] + [make-path (parameter/c (or/c false/c string?))] + [Xvfb-path (parameter/c (or/c false/c string?))] + [fluxbox-path (parameter/c (or/c false/c string?))] + [build? (parameter/c boolean?)] [plt-repository (-> path?)] [path-timing-log (path-string? . -> . path?)] [path-timing-png (path-string? . -> . path?)] diff --git a/collects/meta/drdr/metadata.ss b/collects/meta/drdr/metadata.ss index 65b585c404..16c8de69a3 100644 --- a/collects/meta/drdr/metadata.ss +++ b/collects/meta/drdr/metadata.ss @@ -48,6 +48,7 @@ [path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))]) ;;; Property lookup +(provide props-cache) (define props-cache (make-hasheq)) (define (get-prop a-fs-path prop [def #f] #:as-string? [as-string? #f]) (define rev (current-rev)) diff --git a/collects/meta/drdr/plt-build.ss b/collects/meta/drdr/plt-build.ss index 33a4a7323a..ea3050ccf8 100644 --- a/collects/meta/drdr/plt-build.ss +++ b/collects/meta/drdr/plt-build.ss @@ -95,43 +95,45 @@ (call-with-temporary-home-directory (lambda () e))) (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))) + (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) @@ -287,7 +289,8 @@ (unless (read-cache* (revision-commit-msg rev)) (write-cache! (revision-commit-msg rev) (get-scm-commit-msg rev (plt-repository)))) - (build-revision rev) + (when (build?) + (build-revision rev)) (recur-many (number-of-cpus) (lambda (j inner) (define i (+ j XSERVER-OFFSET)) diff --git a/collects/meta/drdr/run-collect.ss b/collects/meta/drdr/run-collect.ss index bde292ec98..ec1f5c062c 100644 --- a/collects/meta/drdr/run-collect.ss +++ b/collects/meta/drdr/run-collect.ss @@ -106,7 +106,7 @@ [pat subst] ...) s) - (regexp-replace* pat0 + (regexp-replace* (regexp-quote pat0) (regexp-replace** ([pat subst] ...) s) subst0)]))