Fresh home dir per file and rewriting of more random paths

collects/meta/drdr/plt-build.ss

@@ -197,9 +197,7 @@
                                          (lambda ()
                                            (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
+                                                      ["HOME" (make-fresh-home-dir)])
                                              (with-temporary-directory
                                                  (run/collect/wait/log log-pth 
                                                                        #:timeout pth-timeout
@@ -234,14 +232,6 @@
    (build-path log-dir "src" "build" "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))])
-       (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)
@@ -250,10 +240,11 @@
   (notify! "Stopping testing")
   (stop-job-queue! test-workers))
 
-(define (home-dir i)
-  (format "~a~a"
-          (hash-ref (current-env) "HOME")
-          i))
+(define (make-fresh-home-dir)
+  (define new-dir (make-temporary-file "home~a" 'directory))
+  (with-handlers ([exn:fail? void])
+    (copy-directory/files (hash-ref (current-env) "HOME") new-dir))
+  (path->string new-dir))
 
 (define (recur-many i r f)
   (if (zero? i)

collects/meta/drdr/rewriting.ss

@@ -1,30 +1,31 @@
 #lang scheme
-(require "dirstruct.ss"
-         "status.ss")
+(require "status.ss")
 
-(define (rewrite-status s)
-  (if (current-rev)
-      (local [(define from (number->string (current-rev)))]
-        (match s
-          [(struct exit (start end command-line output-log code))
-           (make-exit start end (rewrite-strings from command-line) (rewrite-events from output-log) code)]
-          [(struct timeout (start end command-line output-log))
-           (make-timeout start end (rewrite-strings from command-line) (rewrite-events from output-log))]))
-      s))
+(define (rewrite-status #:rewrite rewrite-string s)
+  (match s
+    [(struct exit (start end command-line output-log code))
+     (make-exit start end 
+                (rewrite-strings #:rewrite rewrite-string command-line)
+                (rewrite-events #:rewrite rewrite-string output-log)
+                code)]
+    [(struct timeout (start end command-line output-log))
+     (make-timeout start end 
+                   (rewrite-strings #:rewrite rewrite-string command-line)
+                   (rewrite-events #:rewrite rewrite-string output-log))]))
 
-(define (rewrite-strings from los)
-  (map (curry rewrite-string from) los))
-(define (rewrite-events from loe) 
-  (map (rewrite-event from) loe))
-(define (rewrite-event from)
+(define (rewrite-strings #:rewrite rewrite-string los)
+  (map rewrite-string los))
+(define (rewrite-events #:rewrite rewrite-string loe) 
+  (map (rewrite-event #:rewrite rewrite-string) loe))
+(define (rewrite-event #:rewrite rewrite-bytes)
   (match-lambda
-    [(struct stdout (b)) (make-stdout (rewrite-bytes from b))]
-    [(struct stderr (b)) (make-stderr (rewrite-bytes from b))]))
+    [(struct stdout (b)) (make-stdout (rewrite-bytes b))]
+    [(struct stderr (b)) (make-stderr (rewrite-bytes b))]))
 
-(define (rewrite-string from s)
-  (regexp-replace* from s "<current-rev>"))
 
-(define rewrite-bytes rewrite-string)
+(define rewrite-string/c
+  ((or/c string? bytes?) . -> . (or/c string? bytes?)))
 
 (provide/contract
- [rewrite-status (status? . -> . status?)])
+ [rewrite-string/c contract?]
+ [rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)])

collects/meta/drdr/run-collect.ss

@@ -2,6 +2,7 @@
 (require "status.ss"
          "notify.ss"
          "rewriting.ss"
+         "dirstruct.ss"
          "cache.ss")
 
 (define (command+args+env->command+args 
@@ -97,6 +98,17 @@
     
     final-status))
 
+(define-syntax regexp-replace**
+  (syntax-rules ()
+    [(_ () s) s]
+    [(_ ([pat0 subst0]
+         [pat subst]
+         ...)
+        s)
+     (regexp-replace* pat0
+                      (regexp-replace** ([pat subst] ...) s)
+                      subst0)]))
+
 (define (run/collect/wait/log log-path command 
                               #:timeout timeout 
                               #:env env
@@ -105,8 +117,20 @@
   (cache/file
    log-path
    (lambda ()
+     (define rev (number->string (current-rev)))
+     (define home (hash-ref env "HOME"))
+     (define tmp (hash-ref env "TMPDIR"))
+     (define cwd (path->string (current-directory)))
+     (define (rewrite s)
+       (regexp-replace** ([rev "<current-rev>"]
+                          [home "<home>"]
+                          [tmp "<tmp>"]
+                          [cwd "<cwd>"])
+                         s))
+     
      (set! ran? #t)
      (rewrite-status
+      #:rewrite rewrite
       (run/collect/wait
        #:timeout timeout
        #:env env