suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Getting it working after the crash

Browse Source
This commit is contained in:
Jay McCarthy 2011-08-08 10:07:51 -06:00
parent 22ac1f8c54
commit a11734d990
7 changed files with 739 additions and 618 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/meta/drdr/INSTALL Normal file
View File

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

25
collects/meta/drdr/analyze.rkt
View File

@ -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)))])
(hash-update! (hash-ref! responsible->problems responsible make-hasheq)
(for ([responsible
(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)))))

2
collects/meta/drdr/copy.sh
View File

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

6
collects/meta/drdr/main.rkt
View File

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

90
collects/meta/drdr/plt-build.rkt
View File

@ -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)
(semaphore-post upper-sema)
(let ()
(cond
[(read-cache* dir-log)
(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?
(test-directory pth dir-sema)
(let ()
(cond
[directory?
(test-directory pth dir-sema)]
[else
(define log-pth (trunk->log pth))
(if (file-exists? log-pth)
(semaphore-post dir-sema)
(let ()
(cond
[(file-exists? log-pth)
(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 (build-path dir ".X11-unix" (format ".X~a-lock" i)))
(safely-delete-directory (build-path dir (format ".tX~a-lock" i)))))
(safely-delete-directory
(build-path dir (format ".X~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))))

58
collects/meta/drdr/render.rkt
View File

@ -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)
(define xe (top-dispatch req))
(define full
(make-xexpr-response xe #:mime-type #"application/xhtml+xml"))
(struct-copy response/full full
[body (list*
#"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"
(response/full-body full))]))
(require (only-in net/url url->string))
(define (log-dispatch req)
(define user-agent
(cond
[(headers-assq #"User-Agent"
(request-headers/raw req))
=> header-value]
[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

3
collects/meta/drdr/static/robots.txt Normal file
View File

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