Getting DrDr at home ready

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)

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)

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?)]
+ [make-path (parameter/c (or/c false/c string?))]
- [Xvfb-path (parameter/c string?)]
+ [Xvfb-path (parameter/c (or/c false/c string?))]
- [fluxbox-path (parameter/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?)]

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))

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)
+  (if command
-    (command+args+env->command+args
+      (local [(define-values (new-command new-args)
-     #:env (current-env)
+                (command+args+env->command+args
-     command args))
+                 #:env (current-env)
-  (define-values
+                 command args))
-    (the-process stdout stdin stderr)
+              (define-values
-    (apply subprocess
+                (the-process stdout stdin stderr)
-           #f #;(current-error-port) 
+                (apply subprocess
-           #f
+                       #f #;(current-error-port) 
-           #f #;(current-error-port)
+                       #f
-           new-command new-args))
+                       #f #;(current-error-port)
-  ; Die if this program does
+                       new-command new-args))
-  (define parent
+              ; Die if this program does
-    (current-thread))
+              (define parent
-  (define waiter
+                (current-thread))
-    (thread
+              (define waiter
-     (lambda ()
+                (thread
-       (subprocess-wait the-process)
+                 (lambda ()
-       (printf "Killing parent because wrapper is dead...~n")
+                   (subprocess-wait the-process)
-       (kill-thread parent))))
+                   (printf "Killing parent because wrapper is dead...~n")
-  
+                   (kill-thread parent))))]
-  ; Run without stdin
+        
-  (close-output-port stdin)
+        ; Run without stdin
-  
+        (close-output-port stdin)
-  (begin0
+        
-    ; Run the thunk
+        (begin0
-    (thunk)
+          ; Run the thunk
-    
+          (thunk)
-    ; Close the output ports
+          
-    (close-input-port stdout)
+          ; Close the output ports
-    (close-input-port stderr)
+          (close-input-port stdout)
-    
+          (close-input-port stderr)
-    ; Kill the guard
+          
-    (kill-thread waiter)
+          ; Kill the guard
-    
+          (kill-thread waiter)
-    ; Kill the process
+          
-    (subprocess-kill the-process #t)))
+          ; 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))

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)]))