Getting it working after the crash

collects/meta/drdr/INSTALL

@@ -0,0 +1,47 @@
+0. Copy source to /opt/plt/drdr
+
+1. Create
+
+/opt/plt
+/opt/plt/plt (Racket install)
+/opt/plt/builds
+/opt/plt/future-builds
+/opt/plt/logs
+/opt/plt/builds/<N> (for the first build)
+
+2. Install stuff
+
+sudo apt-get install xorg fluxbox python-software-properties gcc libcairo2 libpango1.0-0 libgtk2.0-0 texlive lib32gmp3 libreadline5 libpcre3-dev libgmp3-dev
+sudo add-apt-repository ppa:git-core/ppa
+sudo apt-get update
+sudo apt-get install git-core
+
+3. Setup git
+
+cd /opt/plt
+git clone http://git.racket-lang.org/plt.git repo
+
+4. Setup firewall
+
+sudo ufw allow 22
+sudo ufw enable
+
+sudo vim /etc/ufw/before.rules
+
+*nat
+:PREROUTING ACCEPT [0:0]
+-A PREROUTING -p tcp --dport 80 -j REDIRECT --to-port 9000
+COMMIT
+
+sudo ufw allow 80
+sudo ufw allow 9000
+sudo service ufw restart
+
+5.
+
+setuid on /usr/bin/Xorg
+
+6. 
+
+sudo apt-get install postfix
+# Use the Internet site setup

collects/meta/drdr/analyze.rkt

@@ -61,8 +61,11 @@
       (for ([pp (in-list (lc->list lc))])
         (define p (bytes->string/utf-8 pp))
         (define bp (base-path p))
-        (for ([responsible (in-list (rendering-responsibles (log-rendering p)))])
+        (for ([responsible 
-          (hash-update! (hash-ref! responsible->problems responsible make-hasheq)
+               (in-list
+                (rendering-responsibles (log-rendering p)))])
+          (hash-update!
+           (hash-ref! responsible->problems responsible make-hasheq)
            id
            (curry list* bp)
            empty))))
@@ -118,10 +121,19 @@
     (map lc->number
          (list timeout unclean stderr changes)))
   (define totals
-    (apply format "(timeout ~a) (unclean ~a) (stderr ~a) (changes ~a)" (map number->string nums)))
+    (apply 
+     format
+     "(timeout ~a) (unclean ~a) (stderr ~a) (changes ~a)"
+     (map number->string nums)))
   (define (path->url pth)
     (format "http://drdr.racket-lang.org/~a~a" cur-rev pth))
-  (define responsible-ht (statuses->responsible-ht cur-rev timeout unclean stderr changes))
+  (define responsible-ht
+    (statuses->responsible-ht 
+     cur-rev
+     timeout
+     unclean
+     stderr
+     changes))
   (define responsibles 
     (for/list ([(responsible ht) (in-hash responsible-ht)]
                #:when (ormap (curry hash-has-key? ht)
@@ -142,10 +154,11 @@
      ; There is a condition
      (not (empty? responsibles))
      ; It is different from before
-     diff
+     (hash? diff)
      (for*/or ([(r ht) (in-hash diff)]
                [(id ps) (in-hash ht)])
-       (and (for/or ([p (in-list ps)])
+       (and 
+        (for/or ([p (in-list ps)])
           ; XXX This squelch should be disabled if the committer changed this file
           ; XXX But even then it can lead to problems
           (not (path-random? (build-path (revision-trunk-dir cur-rev) (substring (path->string* p) 1)))))

collects/meta/drdr/copy.sh

@@ -1,3 +1,3 @@
 #!/bin/sh
 
-rsync -avz . drdr:/opt/svn/drdr/ --exclude=compiled --delete --exclude=data
+rsync -avz . ${1}drdr:/opt/svn/drdr/ --exclude=compiled --delete --exclude=data

collects/meta/drdr/main.rkt

@@ -49,7 +49,8 @@
         (path->string
          (build-path (plt-directory) "plt" "bin" "racket"))
         "-t" 
-        (path->string (build-path (drdr-directory) "make-archive.rkt"))
+        (path->string
+         (build-path (drdr-directory) "make-archive.rkt"))
         "--"
         "--many" (number->string 100))))))
 
@@ -60,7 +61,8 @@
              cur-rev
              (lambda (newer)
                (for ([rev (in-list newer)])
-                 (write-cache! (future-record-path rev)
+                 (write-cache! 
+                  (future-record-path rev)
                   (get-scm-commit-msg rev (plt-repository)))))
              (lambda (prev-rev cur-rev)
                (handle-revision prev-rev cur-rev)

collects/meta/drdr/plt-build.rkt

@@ -60,7 +60,8 @@
      (build-path log-dir "src" "build" "make")
      (make-path) 
      (list "-j" (number->string (number-of-cpus))))
-    (with-env (["PLT_SETUP_OPTIONS" (format "-j ~a" (number-of-cpus))])
+    (with-env 
+        (["PLT_SETUP_OPTIONS" (format "-j ~a" (number-of-cpus))])
       (run/collect/wait/log
        #:timeout (current-make-install-timeout-seconds)
        #:env (current-env)
@@ -82,11 +83,17 @@
   (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)))
+  (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)))
+       (copy-directory/files
+        (hash-ref (current-env) "HOME")
+        new-dir)))
    (lambda ()
      (with-env (["HOME" (path->string new-dir)])
        (thunk)))
@@ -169,9 +176,10 @@
   (define test-workers (make-job-queue (number-of-cpus)))
   (define (test-directory dir-pth upper-sema)
     (define dir-log (build-path (trunk->log dir-pth) ".index.test"))
-    (if (read-cache* dir-log)
+    (cond
-        (semaphore-post upper-sema)
+      [(read-cache* dir-log)
-        (let ()        
+       (semaphore-post upper-sema)]
+      [else
        (notify! "Testing in ~S" dir-pth)
        (define files/unsorted (directory-list* dir-pth))
        (define dir-sema (make-semaphore 0))
@@ -185,23 +193,27 @@
        (for ([sub-pth (in-list files)])
          (define pth (build-path dir-pth sub-pth))
          (define directory? (directory-exists? pth))
-            (if directory?
+         (cond
-                (test-directory pth dir-sema)
+           [directory?
-                (let ()
+            (test-directory pth dir-sema)]
+           [else
             (define log-pth (trunk->log pth))
-                  (if (file-exists? log-pth)
+            (cond
-                      (semaphore-post dir-sema)
+              [(file-exists? log-pth)
-                      (let ()
+               (semaphore-post dir-sema)]
+              [else
                (define pth-timeout 
                  (or (path-timeout pth)
                      (current-subprocess-timeout-seconds)))
-                        (define pth-cmd/general (path-command-line pth))
+               (define pth-cmd/general
+                 (path-command-line pth))
                (define pth-cmd
                  (match pth-cmd/general
                    [#f
                     #f]
                    [(list-rest (or 'mzscheme 'racket) rst)
-                             (lambda (k) (k (list* racket-path rst)))]
+                    (lambda (k) 
+                      (k (list* racket-path rst)))]
                    [(list-rest 'mzc rst)
                     (lambda (k) (k (list* mzc-path rst)))]
                    [(list-rest 'raco rst)
@@ -217,12 +229,16 @@
                              (k
                               (list* gracket-path 
                                      "-display" 
-                                              (format ":~a" (cpu->child (current-worker)))
+                                     (format
+                                      ":~a"
+                                      (cpu->child
+                                       (current-worker)))
                                      rst)))))
                         #f)]
                    [_
                     #f]))               
-                        (if pth-cmd
+               (cond
+                 [pth-cmd
                   (submit-job!
                    test-workers
                    (lambda ()
@@ -231,24 +247,30 @@
                       (λ ()
                         (pth-cmd
                          (λ (l)
-                                     (with-env (["DISPLAY" (format ":~a" (cpu->child (current-worker)))])
+                           (with-env 
+                               (["DISPLAY" 
+                                 (format ":~a" 
+                                         (cpu->child
+                                          (current-worker)))])
                              (with-temporary-home-directory
                                  (with-temporary-directory
-                                               (run/collect/wait/log log-pth 
+                                     (run/collect/wait/log
+                                      log-pth 
                                       #:timeout pth-timeout
                                       #:env (current-env)
                                       (first l)
                                       (rest l))))))))
                       (λ ()
-                                  (semaphore-post dir-sema)))))
+                        (semaphore-post dir-sema)))))]
-                            (semaphore-post dir-sema)))))))
+                 [else
+                  (semaphore-post dir-sema)])])]))
        (thread
         (lambda ()
           (define how-many (length files))
           (semaphore-wait* dir-sema how-many)
           (notify! "Done with dir: ~a" dir-pth)
           (write-cache! dir-log (current-seconds))
-             (semaphore-post upper-sema))))))
+          (semaphore-post upper-sema)))]))
   ; Some setup
   (for ([pp (in-list (planet-packages))])
     (match pp
@@ -267,7 +289,9 @@
    #:env (current-env)
    (build-path log-dir "src" "build" "set-browser.rkt")
    racket-path 
-   (list "-t" (path->string* (build-path (drdr-directory) "set-browser.rkt"))))
+   (list "-t" 
+         (path->string*
+          (build-path (drdr-directory) "set-browser.rkt"))))
   ; And go
   (define top-sema (make-semaphore 0))
   (notify! "Starting testing")
@@ -292,9 +316,12 @@
 
 (define (remove-X-locks tmp-dir i)
   (for ([dir (in-list (list "/tmp" tmp-dir))])
-    (safely-delete-directory (build-path dir (format ".X~a-lock" i)))
+    (safely-delete-directory 
-    (safely-delete-directory (build-path dir ".X11-unix" (format ".X~a-lock" i)))
+     (build-path dir (format ".X~a-lock" i)))
-    (safely-delete-directory (build-path dir (format ".tX~a-lock" i)))))
+    (safely-delete-directory
+     (build-path dir ".X11-unix" (format ".X~a-lock" i)))
+    (safely-delete-directory
+     (build-path dir (format ".tX~a-lock" i)))))
 
 (define (integrate-revision rev)
   (define test-dir
@@ -323,7 +350,8 @@
                   ["TMPDIR" (path->string tmp-dir)]
                   ["PATH" 
                    (format "~a:~a"
-                           (path->string (build-path trunk-dir "bin"))
+                           (path->string 
+                            (build-path trunk-dir "bin"))
                            (getenv "PATH"))]
                   ["PLTPLANETDIR" (path->string planet-dir)]
                   ["HOME" (path->string home-dir)])
@@ -339,14 +367,20 @@
            (with-running-program
                "/usr/bin/Xorg" (list (format ":~a" i))
              (lambda ()
-               (sleep 1)
+               (sleep 2)
+               (notify! "Starting fluxbox #~a" i)
                (with-running-program
-                   (fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init")
+                   (fluxbox-path) 
+                 (list "-display"
+                       (format ":~a" i)
+                       "-rc" "/home/pltdrdr/.fluxbox/init")
                  inner))))
          
          (start-x-server 
           ROOTX 
           (lambda ()
+            (sleep 2)
+            (notify! "Starting test of rev ~a" rev)
             (test-revision rev)))))
      ; Remove the test directory
      (safely-delete-directory test-dir))))

collects/meta/drdr/render.rkt

@@ -50,6 +50,8 @@
   (local [(define end (newest-completed-revision))]
     (let loop ([rev (add1 (current-rev))])
       (cond
+        [(not end)
+         #f]
         [(<= end rev)
          end]
         [(read-cache* (build-path (revision-dir rev) "analyzed"))
@@ -283,6 +285,7 @@
         (define prev-rev-url (format "/~a~a" (previous-rev) the-base-path))
         (define cur-rev-url (format "/~a~a" "current" the-base-path))
         (define output (map render-event output-log))
+        (response/xexpr
          `(html (head (title ,title)
                       (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
                 (body 
@@ -331,7 +334,7 @@
                             #;(regexp-replace* #rx"&(?![a-z]+;)" content "\\&amp;\\1")
                             (regexp-replace* #rx"&gt;" content ">"))
                           ))
-                     ,(footer))))])]))
+                      ,(footer)))))])]))
 
 (define (number->string/zero v)
   (cond 
@@ -363,6 +366,7 @@
               empty
               (cached-directory-list* dir-pth)))
      (define-values (title breadcrumb) (path->breadcrumb dir-pth #t))
+     (response/xexpr
       `(html (head (title ,title)
                    (script ([src "/sorttable.js"]) " ")
                    (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
@@ -515,9 +519,10 @@
                                (td ,(number->string/zero (lc->number tot-stderr)))
                                (td ,(number->string/zero (lc->number tot-changes)))
                                (td " "))))
-                  ,(footer))))]))
+                   ,(footer)))))]))
 
 (define (show-help req)
+  (response/xexpr
    `(html
      (head (title "DrDr > Help")
            (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
@@ -605,10 +610,13 @@
                                    @p{The next thing is to structure your code so DrDr does not do the same work many times. For example, because DrDr will load every file if your test suite is broken up into different parts that execute when loaded @em{and} they are all loaded by some other file, then DrDr will load and run them twice. The recommended solution is to have DrDr ignore the combining file or change it so a command-line argument is needed to run everything but is not provided by DrDr, that way the combining code is compiled but the tests are run once.}
                                    
                                    }                                           
-          ,(footer)))))
+           ,(footer))))))
+
+(define (take* l i)
+  (take l (min (length l) i)))
 
 (define (list-limit len offset l)
-  (take (drop l offset) len))
+  (take* (drop l offset) len))
 
 (define (string-first-line s)
   (define v
@@ -662,6 +670,7 @@
     (append future-revs built-or-building-revs))
   (define how-many-total-revs
     (length all-revs))
+  (response/xexpr
    `(html
      (head (title "DrDr")
            (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
@@ -769,7 +778,7 @@
                                                    (top-url show-revisions)
                                                    (- how-many-total-revs how-many-revs))])
                                    (img ([src "/images/skip-forward1.png"])))))))
-          ,(footer)))))
+           ,(footer))))))
 
 (define (show-revision req rev)
   (define log-dir (revision-log-dir rev))
@@ -783,6 +792,7 @@
 
 (define (file-not-found file-pth)
   (define-values (title breadcrumb) (path->breadcrumb file-pth #f))
+  (response/xexpr
    `(html
      (head (title ,title " > Not Found")
            (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
@@ -791,9 +801,10 @@
            ,breadcrumb
            (div ([class "error"])
                 "This file does not exist in push #" ,(number->string (current-rev)) " or has not been tested.")
-          ,(footer)))))
+           ,(footer))))))
 (define (dir-not-found dir-pth)
   (define-values (title breadcrumb) (path->breadcrumb dir-pth #t))
+  (response/xexpr
    `(html
      (head (title ,title " > Not Found")
            (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
@@ -802,9 +813,10 @@
            ,breadcrumb
            (div ([class "error"])
                 "This directory does not exist in push #" ,(number->string (current-rev)) " or has not been tested.")
-          ,(footer)))))
+           ,(footer))))))
 (define (rev-not-found dir-pth path-to-file)
   (define-values (title breadcrumb) (path->breadcrumb dir-pth #t))
+  (response/xexpr
    `(html
      (head (title ,title " > Not Found")
            (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
@@ -813,7 +825,7 @@
            ,breadcrumb
            (div ([class "error"])
                 "Push #" ,(number->string (current-rev)) " does not exist or has not been tested.")
-          ,(footer)))))
+           ,(footer))))))
 
 (define (find-previous-rev this-rev)
   (if (zero? this-rev)
@@ -874,6 +886,7 @@
         (format "DrDr / File Difference / ~a (~a:~a)"
                 f-str r1 r2))
       
+      (response/xexpr
        `(html (head (title ,title)
                     (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
               (body 
@@ -898,7 +911,7 @@
                                             (td ,(render-event new)))]
                                       [(struct same-itude (e))
                                        `(tr (td ([colspan "2"]) ,(render-event e)))]))))
-                   ,(footer)))))))
+                    ,(footer))))))))
 
 (define-values (top-dispatch top-url)
   (dispatch-rules
@@ -910,18 +923,27 @@
    [((integer-arg) "") show-revision]
    [((integer-arg) (string-arg) ...) show-file]))
 
-#;(define (xml-dispatch req)
+(require (only-in net/url url->string))
-  (define xe (top-dispatch req))
+(define (log-dispatch req)
-  (define full
+  (define user-agent
-    (make-xexpr-response xe #:mime-type #"application/xhtml+xml"))
+    (cond
-  (struct-copy response/full full
+      [(headers-assq #"User-Agent"
-               [body (list* 
+                     (request-headers/raw req))
-                      #"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"
+       => header-value]
-                      (response/full-body full))]))
+      [else
+       #"Unknown"]))
+  (cond
+    [(regexp-match #"Googlebot" user-agent)
+     (response/xexpr "Please, do not index.")]
+    [else
+     (printf "~a - ~a\n"
+             (url->string (request-uri req))
+             user-agent)
+     (top-dispatch req)]))
 
 (date-display-format 'iso-8601)
 (cache/file-mode 'no-cache)
-(serve/servlet top-dispatch
+(serve/servlet log-dispatch
                #:port 9000
                #:listen-ip #f
                #:quit? #f

collects/meta/drdr/static/robots.txt

@@ -0,0 +1,3 @@
+# go away
+User-agent: *
+Disallow: /