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

Split drdr from the main repository.

Browse Source 
The `drdr` pkg is available at:
  https://github.com/racket/drdr

The pkgs.rktd file is kept to manage the pkgs built
by DrDr on each push.
This commit is contained in:
Sam Tobin-Hochstadt 2014-11-28 15:23:30 -05:00
parent 58896d8d23
commit 4ace325562
69 changed files with 0 additions and 10623 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
pkgs/plt-services/meta/drdr/INSTALL
View File

@ -1,52 +0,0 @@
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
# https://help.ubuntu.com/10.04/serverguide/certificates-and-security.html
# https://www.wormly.com/blog/2008/11/05/relay-gmail-google-smtp-postfix/
# Use the Internet site setup
# Set a relyhost of mail.cs.byu.edu

7
pkgs/plt-services/meta/drdr/README
View File

@ -1,7 +0,0 @@
This is the implementation of DrDr.
It currently only runs on a single machine that is set up in an intricate way.
-- In particular, config.rkt mentions many of those details
-- Also, static/data must be a link to a data directory (/opt/plt/data)
It uses a few of my PLaneT packages and some other ones as well.

18
pkgs/plt-services/meta/drdr/README-PORTS
View File

@ -1,18 +0,0 @@
Please register which TCP ports your tests are using in this file so
others don't accidentally conflict.
6000 - DrDr X11 server
....
6100 - DrDr X11 server
8887 - tests/racket/benchmarks/shootout/echo
8888 - tests/racket/benchmarks/shootout/typed/echo (non-optimized)
8889 - tests/racket/benchmarks/shootout/typed/echo (optimized)
9000 - DrDr Web server
9001 - tests/net
9990 - tests/pkg
9997 - tests/pkg
9998 - tests/pkg
9999 - tests/web-server
19200 - 2htdp/tests
...
19209 - 2htdp/tests

377
pkgs/plt-services/meta/drdr/analyze.rkt
View File

@ -1,377 +0,0 @@
#lang racket
(require racket/file
"diff.rkt"
"scm.rkt"
"list-count.rkt"
"notify.rkt"
"cache.rkt"
"dirstruct.rkt"
"status.rkt"
"metadata.rkt"
"path-utils.rkt"
"rendering.rkt")
(provide (all-from-out "rendering.rkt"))
; Email
(require net/sendmail
"formats.rkt")
(define list@
(match-lambda
[(and c (cons x y))
(if (lc-zero? x)
empty
(list c))]))
(define (list-limit l n)
(for/list ([e (in-list l)]
[i (in-range n)])
e))
(define responsible-ht-id->str
#hasheq([timeout . "Timeout"]
[unclean . "Unclean Exit"]
[stderr . "STDERR Output"]
[changes . "Changes"]))
(define responsible-ht-severity
'(timeout unclean stderr changes))
(define (rev->responsible-ht rev)
(define log-dir (revision-log-dir rev))
(define top-analyze
(parameterize ([cache/file-mode 'no-cache]
[current-rev rev])
(dir-rendering log-dir)))
(rendering->responsible-ht rev top-analyze))
(define (rendering->responsible-ht rev top-analyze)
(match-define
(struct rendering (_ _ _ timeout unclean stderr _ changes))
top-analyze)
(statuses->responsible-ht rev timeout unclean stderr changes))
(define (statuses->responsible-ht rev timeout unclean stderr changes)
(parameterize ([current-rev rev])
(define log-dir (revision-log-dir rev))
(define base-path
(rebase-path log-dir "/"))
(define responsible->problems (make-hash))
(for ([lc (in-list (list timeout unclean stderr changes))]
[id (in-list responsible-ht-severity)])
(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)
id
(curry list* bp)
empty))))
responsible->problems))
(define (2hash-copy ht)
(define 2ht (make-hash))
(for ([(r ht) (in-hash ht)])
(hash-set! 2ht r (hash-copy ht)))
2ht)
(define (responsible-ht-difference old new)
(let ([ht (2hash-copy new)])
(for ([(r rht) (in-hash old)])
(define nrht (hash-ref! ht r make-hash))
(for ([(id ps) (in-hash rht)])
(hash-update! nrht id
(curry remove* ps)
empty)
(when (zero? (length (hash-ref nrht id)))
(hash-remove! nrht id)))
(when (zero? (hash-count nrht))
(hash-remove! ht r)))
ht))
(define responsible-ht/c
(hash/c string? (hash/c symbol? (listof path?))))
(define (responsible-ht->status-ht diff)
(for/hash ([id (in-list responsible-ht-severity)])
(define id-l
(for*/list ([(_ ht) (in-hash diff)]
[f (in-list (hash-ref ht id empty))])
f))
(values id (remove-duplicates id-l))))
(provide/contract
[rendering->responsible-ht
(exact-positive-integer? rendering? . -> . responsible-ht/c)]
[statuses->responsible-ht
(exact-positive-integer? list/count list/count list/count list/count . -> . responsible-ht/c)]
[responsible-ht-severity (listof symbol?)]
[responsible-ht-id->str (hash/c symbol? string?)]
[responsible-ht-difference (responsible-ht/c responsible-ht/c . -> . responsible-ht/c)])
(define ERROR-LIMIT 50)
(define (notify cur-rev
start end
duration
timeout unclean stderr changes)
(define abs-dur (- end start))
(define nums
(map lc->number
(list timeout unclean stderr changes)))
(define totals
(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 responsibles
(for/list ([(responsible ht) (in-hash responsible-ht)]
#:when (ormap (curry hash-has-key? ht)
(take responsible-ht-severity 3)))
(match responsible
["nobody" "drdr-nobody"]
[x x])))
(define committer
(with-handlers ([exn:fail? (lambda (x) #f)])
(scm-commit-author
(read-cache*
(revision-commit-msg cur-rev)))))
(define diff
(with-handlers ([exn:fail? (lambda (x) #t)])
(define old (rev->responsible-ht (previous-rev)))
(responsible-ht-difference old responsible-ht)))
(define include-committer?
(and ; The committer can be found
committer
; There is a condition
(not (empty? responsibles))
; It is different from before
(hash? diff)
(for*/or ([(r ht) (in-hash diff)]
[(id ps) (in-hash ht)])
(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)))))
(not (symbol=? id 'changes))))))
(define mail-recipients
(remove-duplicates
(append (if include-committer?
(list committer)
empty)
responsibles)))
; Send messages to everyone...
(unless (andmap zero? nums)
(for ([r (in-list mail-recipients)])
(send-mail-message
"drdr@racket-lang.org"
(format "[DrDr] R~a ~a"
cur-rev totals)
(list (format "~a@racket-lang.org" r))
empty empty
(flatten
(list (format "DrDr has finished building push #~a after ~a."
cur-rev
(format-duration-ms abs-dur))
""
(format "http://drdr.racket-lang.org/~a/"
cur-rev)
""
(if (and include-committer? (equal? committer r))
(list
(format "Push #~a (which you did) contained a NEW condition that may need inspecting." cur-rev)
(let ([diff-smash (responsible-ht->status-ht diff)])
(for/list ([(id paths) (in-hash diff-smash)]
#:when (not (symbol=? id 'changes)))
(if (empty? paths)
empty
(list (format " ~a" id)
(for/list ([f (in-list paths)]
[i (in-range ERROR-LIMIT)]
#:when (not (path-random?
(build-path (revision-trunk-dir cur-rev)
(substring (path->string* f) 1)))))
(format " ~a" (path->url f)))
""))))
"")
empty)
(if (hash-has-key? responsible-ht r)
(list* "A file you are responsible for has a condition that may need inspecting."
(for/list ([(id files) (in-hash (hash-ref responsible-ht r))]
#:when (not (symbol=? id 'changes)))
(list (format " ~a:" id)
(for/list ([f (in-list files)]
[i (in-range ERROR-LIMIT)])
(format " ~a" (path->url f)))
""))
"")
empty))))))
; Send message to IRC
(send-mail-message "drdr@racket-lang.org"
(format "http://drdr.racket-lang.org/~a/"
cur-rev)
(list "eli+ircbot@eli.barzilay.org")
empty empty
(list* (format " (abs ~a) (sum ~a) ~a"
(format-duration-ms abs-dur)
(format-duration-ms duration)
totals)
(if (empty? responsibles)
empty
(list (apply string-append (add-between responsibles " ")))))))
; End Email
(define (trunk-path pth)
(define rev (current-rev))
((rebase-path (revision-log-dir rev) (revision-trunk-dir rev))
pth))
(define (analyze-path pth dir?)
(define rev (current-rev))
(define log-dir (revision-log-dir rev))
(define analyze-dir (revision-analyze-dir rev))
(define the-analyze-path
((rebase-path log-dir analyze-dir) pth))
(if dir?
(build-path the-analyze-path "index.analyze")
(path-add-suffix the-analyze-path ".analyze")))
(define (analyze-revision cur-rev)
(cache/file/timestamp
(build-path (revision-dir cur-rev) "analyzed")
(lambda ()
(match (analyze-logs cur-rev)
[(struct rendering (start end duration timeout unclean stderr _ changes))
(notify cur-rev
start end
duration
timeout unclean stderr changes)]
[#f
(void)])
(safely-delete-directory (revision-trunk-dir cur-rev))
(void))))
(define (analyze-logs rev)
(define log-dir (revision-log-dir rev))
(define analyze-dir (revision-analyze-dir rev))
(make-directory* analyze-dir)
(parameterize ([current-rev rev])
(dir-rendering log-dir #:committer? #t)))
(define (drdr-random-notification? l)
(and (stdout? l)
(regexp-match #rx"DrDr: This file has random output."
(stdout-bytes l))))
(define (log-rendering log-pth)
; XXX
(if (or #t (file-exists? log-pth))
(cache/file
(analyze-path log-pth #f)
(lambda ()
#;(notify! "Analyzing log: ~S" log-pth)
(match (read-cache log-pth)
[(? eof-object?)
#f]
[(and log (struct status (start end command-line output-log)))
(define dur (status-duration log))
(define any-stderr? (ormap stderr? output-log))
(define changed?
(if (and (previous-rev)
(not (path-random? (trunk-path log-pth)))
(not (ormap drdr-random-notification? output-log)))
(with-handlers ([exn:fail?
;; This #f means that new files are
;; NOT considered changed
(lambda (x) #f)])
(define prev-log-pth
((rebase-path (revision-log-dir (current-rev))
(revision-log-dir (previous-rev)))
log-pth))
(log-different? output-log
(status-output-log (read-cache prev-log-pth))))
#f))
(define responsible
(or (path-responsible (trunk-path log-pth))
(and (regexp-match #rx"/planet/" (path->string* log-pth))
"jay")
; XXX maybe mflatt, eli, or tewk
(and (regexp-match #rx"/src/" (path->string* log-pth))
"jay")
"nobody"))
(define lc
(list (path->bytes log-pth)))
(make-rendering start end dur
(if (timeout? log) lc empty)
(if (exit? log)
(if (zero? (exit-code log)) empty lc)
empty)
(if any-stderr? lc empty)
responsible
(if changed? lc empty))])))
#f))
(define (dir-rendering dir-pth
#:committer? [committer? #f])
; XXX
(if (or #t (directory-exists? dir-pth))
(cache/file
(analyze-path dir-pth #t)
(lambda ()
(notify! "Analyzing dir: ~S" dir-pth)
(foldl (lambda (sub-pth acc)
(define pth (build-path dir-pth sub-pth))
(define directory? (directory-exists? pth))
(define (next-rendering)
(if directory?
(dir-rendering pth)
(log-rendering pth)))
(match (next-rendering)
[#f
acc]
[(and n (struct rendering (pth-start pth-end pth-dur pth-timeouts pth-unclean-exits pth-stderrs _pth-responsible pth-changed)))
(match acc
[#f n]
[(struct rendering (acc-start acc-end acc-dur acc-timeouts acc-unclean-exits acc-stderrs acc-responsible acc-changed))
(make-rendering (min pth-start acc-start)
(max pth-end acc-end)
(+ pth-dur acc-dur)
(lc+ pth-timeouts acc-timeouts)
(lc+ pth-unclean-exits acc-unclean-exits)
(lc+ pth-stderrs acc-stderrs)
acc-responsible
(lc+ pth-changed acc-changed))])]))
(make-rendering
+inf.0 -inf.0 0
empty empty empty
(or
(and committer?
(with-handlers ([exn:fail? (lambda (x) #f)])
(scm-commit-author (read-cache (revision-commit-msg (current-rev))))))
(or (path-responsible (trunk-path dir-pth))
"nobody"))
empty)
(directory-list* dir-pth))))
#f))
(provide/contract
[analyze-revision (exact-nonnegative-integer? . -> . void)]
[analyze-logs (exact-nonnegative-integer? . -> . void)]
[log-rendering (path-string? . -> . (or/c rendering? false/c))]
[dir-rendering (path-string? . -> . (or/c rendering? false/c))])

17
pkgs/plt-services/meta/drdr/archive-repair.rkt
View File

@ -1,17 +0,0 @@
#lang racket
(require "config.rkt"
"archive.rkt"
"path-utils.rkt"
"dirstruct.rkt"
"make-archive-lib.rkt")
(init-revisions!)
(define rev
(command-line #:program "archive-repair"
#:args (n) (string->number n)))
(when (file-exists? (revision-archive rev))
(archive-extract-to (revision-archive rev) (revision-dir rev) (revision-dir rev))
(delete-file (revision-archive rev))
(make-archive rev))

17
pkgs/plt-services/meta/drdr/archive-repair.sh
View File

@ -1,17 +0,0 @@
#!/bin/bash
cd /opt/plt/builds
du -h */archive.db | awk '{print $1}' | sort -n | uniq -c
echo
for rev in $(du -h */archive.db | sort -n | tail | awk '{print $2}' | awk -F/ '{print $1}' | tac) ; do
du -h ${rev}/archive.db
/opt/plt/plt/bin/racket -t /opt/svn/drdr/archive-repair.rkt -- $rev > /dev/null
done
echo
du -h */archive.db | awk '{print $1}' | sort -n | uniq -c
echo
df -h

32
pkgs/plt-services/meta/drdr/archive-test.rkt
View File

@ -1,32 +0,0 @@
#lang racket
(require "path-utils.rkt"
"archive.rkt"
tests/eli-tester)
(define archive
"../test.archive")
(test
(create-archive archive (current-directory))
(for ([fp (in-list (directory-list* (current-directory)))]
#:when (file-exists? fp))
(test
(archive-extract-file archive (build-path (current-directory) fp)) => (file->bytes fp)))
(archive-extract-file archive "test") =error> #rx"not in the archive"
(archive-extract-file archive (build-path (current-directory) "test")) =error> #rx"not in the archive"
(archive-extract-file archive (build-path (current-directory) "static")) =error> #rx"not a file"
(archive-extract-file "archive-test.rkt" (build-path (current-directory) "archive-test.rkt")) =error> #rx"not a valid archive"
(directory-list->directory-list* (archive-directory-list archive (current-directory)))
=> (directory-list* (current-directory))
(archive-directory-exists? archive (current-directory)) => #t
(archive-directory-exists? archive (build-path (current-directory) "static")) => #t
(archive-directory-exists? archive (build-path (current-directory) "unknown")) => #f
(archive-directory-exists? archive (build-path (current-directory) "archive-test.rkt")) => #f
)

150
pkgs/plt-services/meta/drdr/archive.rkt
View File

@ -1,150 +0,0 @@
#lang racket
(require "path-utils.rkt")
(define (value->bytes v)
(with-output-to-bytes (lambda () (write v))))
(define (bytes->value bs ? err)
(define v (with-input-from-bytes bs read))
(unless (? v) (err))
v)
(define (create-archive archive-path root)
(define start 0)
(define vals empty)
(define (make-table path)
(for/hash ([p (in-list (directory-list path))])
(define fp (build-path path p))
(define directory?
(directory-exists? fp))
(define val
(if directory?
(value->bytes (make-table fp))
(file->bytes fp)))
(define len (bytes-length val))
(begin0
(values (path->string p)
(vector directory? start len))
(set! start (+ start len))
(set! vals (cons val vals)))))
(define root-table
(value->bytes (make-table root)))
(with-output-to-file archive-path
#:exists 'replace
(lambda ()
(write (path->string* root))
(write root-table)
(for ([v (in-list (reverse vals))])
(write-bytes v)))))
(define (read/? p ? err)
(with-handlers ([exn:fail? (lambda (x) (err))])
(define v (read p))
(if (? v) v
(err))))
(define (archive-extract-path archive-path p)
(define ps (explode-path p))
(define (not-in-archive)
(error 'archive-extract-path "~e is not in the archive" p))
(define (bad-archive)
(error 'archive-extract-path "~e is not a valid archive" archive-path))
(call-with-input-file
archive-path
(lambda (fport)
(dynamic-wind
void
(lambda ()
(define root-string (read/? fport string? bad-archive))
(define root (string->path root-string))
(define roots (explode-path root))
(define root-len (length roots))
(unless (root-len . <= . (length ps))
(not-in-archive))
(local [(define ps-roots (list-tail ps root-len))
(define root-table-bytes (read/? fport bytes? bad-archive))
(define root-table (bytes->value root-table-bytes hash? bad-archive))
(define heap-start (file-position fport))
(define (extract-bytes t p)
(match (hash-ref t (path->string p) not-in-archive)
[(vector directory? file-start len)
; Jump ahead in the file
(file-position fport (+ heap-start file-start))
; Read the bytes
(local [(define bs (read-bytes len fport))]
(unless (= (bytes-length bs) len)
(bad-archive))
(values directory? bs))]))
(define (extract-table t p)
(define-values (dir? bs) (extract-bytes t p))
(if dir?
(bytes->value bs hash? bad-archive)
(not-in-archive)))
(define (find-file ps-roots table)
(match ps-roots
[(list p)
(extract-bytes table p)]
[(list-rest p rst)
(find-file rst (extract-table table p))]))]
(if (empty? ps-roots)
(values #t root-table-bytes)
(find-file ps-roots root-table))))
(lambda ()
(close-input-port fport))))))
(define (archive-extract-file archive-path fp)
(define-values (dir? bs) (archive-extract-path archive-path fp))
(if dir?
(error 'archive-extract-file "~e is not a file" fp)
bs))
(define (archive-directory-list archive-path fp)
(define (bad-archive)
(error 'archive-directory-list "~e is not a valid archive" archive-path))
(define-values (dir? bs) (archive-extract-path archive-path fp))
(if dir?
(for/list ([k (in-hash-keys (bytes->value bs hash? bad-archive))])
(build-path k))
(error 'archive-directory-list "~e is not a directory" fp)))
(define (archive-directory-exists? archive-path fp)
(define-values (dir? _)
(with-handlers ([exn:fail? (lambda (x) (values #f #f))])
(archive-extract-path archive-path fp)))
dir?)
(define (archive-extract-to archive-file-path archive-inner-path to)
(printf "~a " to)
(cond
[(archive-directory-exists? archive-file-path archive-inner-path)
(printf "D\n")
(make-directory* to)
(for ([p (in-list (archive-directory-list archive-file-path archive-inner-path))])
(archive-extract-to archive-file-path
(build-path archive-inner-path p)
(build-path to p)))]
[else
(printf "F\n")
(unless (file-exists? to)
(with-output-to-file to
#:exists 'error
(λ ()
(write-bytes (archive-extract-file archive-file-path archive-inner-path)))))]))
(provide/contract
[create-archive
(-> path-string? path-string?
void)]
[archive-extract-to
(-> path-string? path-string? path-string?
void)]
[archive-extract-file
(-> path-string? path-string?
bytes?)]
[archive-directory-list
(-> path-string? path-string?
(listof path?))]
[archive-directory-exists?
(-> path-string? path-string?
boolean?)])

88
pkgs/plt-services/meta/drdr/cache.rkt
View File

@ -1,88 +0,0 @@
#lang racket
(require "path-utils.rkt")
; (symbols 'always 'cache 'no-cache)
(define cache/file-mode (make-parameter 'cache))
(define (cache/file pth thnk)
(define mode (cache/file-mode))
(define (recompute!)
(define v (thnk))
(write-cache! pth v)
v)
(case mode
[(always) (recompute!)]
[(cache no-cache)
(with-handlers
([exn:fail?
(lambda (x)
(case mode
[(no-cache) (error 'cache/file "No cache available: ~a" pth)]
[(cache always)
#;(printf "cache/file: running ~S for ~a\n" thnk pth)
(recompute!)]))])
(read-cache pth))]))
(define (cache/file/timestamp pth thnk)
(cache/file
pth
(lambda ()
(thnk)
(current-seconds)))
(void))
(require "archive.rkt"
"dirstruct.rkt")
(define (consult-archive pth)
(define rev (path->revision pth))
(define archive-path (revision-archive rev))
(define file-bytes
(archive-extract-file archive-path pth))
(with-input-from-bytes file-bytes read))
(define (consult-archive/directory-list* pth)
(define rev (path->revision pth))
(define archive-path (revision-archive rev))
(directory-list->directory-list* (archive-directory-list archive-path pth)))
(define (consult-archive/directory-exists? pth)
(define rev (path->revision pth))
(define archive-path (revision-archive rev))
(archive-directory-exists? archive-path pth))
(define (cached-directory-list* dir-pth)
(if (directory-exists? dir-pth)
(directory-list* dir-pth)
(or (with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive/directory-list* dir-pth))
(error 'cached-directory-list* "Directory list is not cached: ~e" dir-pth))))
(define (cached-directory-exists? dir-pth)
(if (file-exists? dir-pth)
#f
(or (directory-exists? dir-pth)
(with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive/directory-exists? dir-pth)))))
(define (read-cache pth)
(if (file-exists? pth)
(file->value pth)
(or (with-handlers ([exn:fail? (lambda _ #f)]) (consult-archive pth))
(error 'read-cache "File is not cached: ~e" pth))))
(define (read-cache* pth)
(with-handlers ([exn:fail? (lambda (x) #f)])
(read-cache pth)))
(define (write-cache! pth v)
(write-to-file* v pth))
(define (delete-cache! pth)
(with-handlers ([exn:fail? void])
(delete-file pth)))
(provide/contract
[cache/file-mode (parameter/c (symbols 'always 'cache 'no-cache))]
[cache/file (path-string? (-> any/c) . -> . any/c)]
[cache/file/timestamp (path-string? (-> void) . -> . void)]
[cached-directory-list* (path-string? . -> . (listof path-string?))]
[cached-directory-exists? (path-string? . -> . boolean?)]
[read-cache (path-string? . -> . any/c)]
[read-cache* (path-string? . -> . any/c)]
[write-cache! (path-string? any/c . -> . void)]
[delete-cache! (path-string? . -> . void)])

81
pkgs/plt-services/meta/drdr/cc.rkt
View File

@ -1,81 +0,0 @@
#lang racket
(require "path-utils.rkt"
"run-collect.rkt"
"replay.rkt"
racket/runtime-path
racket/system)
(match-define
(list* command real-args)
(vector->list (current-command-line-arguments)))
(define-match-expander solo-flag
(syntax-rules ()
[(_ [flag ...] everything-else)
(list* (or (regexp (string-append "^" (regexp-quote flag) "$" ) (list _))
...)
everything-else)]))
(define-match-expander emopt-flag
(syntax-rules ()
[(_ [flag ...] everything-else)
(list* (or (regexp (string-append "^" (regexp-quote flag) "(.+)$") (list _ _))
...)
everything-else)]))
(define-match-expander opt-flag
(syntax-rules ()
[(_ [flag ...] opt everything-else)
(list* (or (regexp (string-append "^" (regexp-quote flag) "$") (list _))
...)
(and opt (not (? flag?)))
everything-else)]))
(define (flag? x)
(equal? #\- (string-ref x 0)))
(define-syntax-rule (define-snocer var setter!)
(begin (define var empty)
(define (setter! x)
(set! var (append var (list x))))))
(define-snocer outputs output!)
(define-snocer inputs input!)
(define loop
(match-lambda
[(solo-flag ["--version" "-c" "-V" "-v" "-E" "-traditional-cpp" "-g" "-print-search-dirs" "-print-multi-os-directory" "-pthread" "-dynamiclib" "-all_load"] as) (loop as)]
[(emopt-flag ["-O" "-X" "-D" "-m" "-l" "-W" "-I" "-f" "-F"] as) (loop as)]
[(opt-flag ["-install_name" "-compatibility_version" "-current_version" "-framework"] f as) (loop as)]
[(opt-flag ["-o"] f as) (output! f) (loop as)]
[(list* (and (not (? flag?)) f) as) (input! f) (loop as)]
[args
(unless (empty? args)
(error 'drdr-cc "Unhandled args: ~S [~S]" args real-args))]))
(loop real-args)
(define cc-path
(find-executable-path command))
(define the-input
(match inputs
[(list f) f]
[_ #f]))
(define-runtime-path output-dir "output")
(if the-input
(local [(define the-input-base
(apply build-path output-dir (filter path-for-some-system? (explode-path the-input))))
(define status
(run/collect/wait
#:env (make-hash)
#:timeout (* 60 60)
(path->string cc-path)
real-args))]
(make-parent-directory the-input-base)
(with-output-to-file (path-add-suffix the-input-base ".log") #:exists 'truncate/replace
(lambda () (write status)))
(replay-status status))
(exit (apply system*/exit-code cc-path real-args)))

57
pkgs/plt-services/meta/drdr/config.rkt
View File

@ -1,57 +0,0 @@
#lang racket
(require "cache.rkt"
"dirstruct.rkt"
"scm.rkt"
"monitor-scm.rkt")
(plt-directory "/opt/plt")
(drdr-directory "/opt/svn/drdr")
(git-path "/usr/bin/git")
(Xvfb-path "/usr/bin/Xnest")
(fluxbox-path "/usr/bin/metacity")
(vncviewer-path "/usr/bin/vncviewer")
(current-make-install-timeout-seconds (* 90 60))
(current-make-timeout-seconds (* 90 60))
(current-subprocess-timeout-seconds 90)
(current-monitoring-interval-seconds 60)
(number-of-cpus 12)
(define (string->number* s)
(with-handlers ([exn:fail? (lambda (x) #f)])
(let ([v (string->number s)])
(and (number? v)
v))))
(define revisions #f)
(define (init-revisions!)
(set! revisions
(sort
(filter-map
(compose string->number* path->string)
(directory-list (plt-build-directory)))
<)))
(define (newest-revision)
(last revisions))
(define (second-to-last l)
(list-ref l (- (length l) 2)))
(define (second-newest-revision)
(with-handlers ([exn:fail? (lambda (x) #f)])
(second-to-last revisions)))
(define (newest-completed-revision)
(define n (newest-revision))
(if (read-cache* (build-path (revision-dir n) "analyzed"))
n
(second-newest-revision)))
(provide/contract
[revisions (or/c false/c (listof exact-nonnegative-integer?))]
[init-revisions! (-> void)]
[newest-revision (-> exact-nonnegative-integer?)]
[second-newest-revision (-> (or/c false/c exact-nonnegative-integer?))]
[newest-completed-revision (-> (or/c false/c exact-nonnegative-integer?))])

3
pkgs/plt-services/meta/drdr/copy.sh
View File

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

84
pkgs/plt-services/meta/drdr/diff.rkt
View File

@ -1,84 +0,0 @@
#lang racket
(require "status.rkt")
(define (timing? bs)
(regexp-match #px#"cpu time: \\d+ real time: \\d+ gc time: \\d+" bs))
(define do-not-compare? timing?)
(define (find-next p? l)
(match l
[(list)
(values)]
[(list-rest (? p? e) l)
(values e l)]
[(list-rest n l)
(call-with-values
(lambda ()
(find-next p? l))
(case-lambda
[()
(values)]
[(e r)
(values e (list* n r))]))]))
(define (same? b1 b2)
(or (and (do-not-compare? b1) (do-not-compare? b2))
(bytes=? b1 b2)))
(define (different? b1 b2)
(not (same? b1 b2)))
(define (log-different? l1 l2)
(let loop ([l1 l1] [l2 l2])
(match l1
[(list)
(not (empty? l2))]
[(list-rest e1 r1)
(define (inner bs p? p-bytes)
(call-with-values
(lambda () (find-next p? l2))
(case-lambda
[() #t]
[(e2 r2)
(or (different? bs (p-bytes e2))
(loop r1 r2))])))
(match e1
[(struct stdout (bs))
(inner bs stdout? stdout-bytes)]
[(struct stderr (bs))
(inner bs stderr? stderr-bytes)])])))
(define-struct difference (old new))
(define-struct same-itude (e))
(define (render-log-difference l1 l2)
(let loop ([l1 l1] [l2 l2])
(match l1
[(list)
(map (match-lambda
[(? stdout? e2)
(make-difference (make-stdout #"") e2)]
[(? stderr? e2)
(make-difference (make-stderr #"") e2)])
l2)]
[(list-rest e1 r1)
(define (inner bs make-p p? p-bytes)
(call-with-values
(lambda () (find-next p? l2))
(case-lambda
[()
(list* (make-difference e1 (make-p #""))
(loop r1 l2))]
[(e2 r2)
(if (different? bs (p-bytes e2))
(list* (make-difference e1 e2)
(loop r1 r2))
(list* (make-same-itude e1)
(loop r1 r2)))])))
(match e1
[(struct stdout (bs))
(inner bs make-stdout stdout? stdout-bytes)]
[(struct stderr (bs))
(inner bs make-stderr stderr? stderr-bytes)])])))
(provide (all-defined-out))

35
pkgs/plt-services/meta/drdr/diffcmd.rkt
View File

@ -1,35 +0,0 @@
#lang racket
(require racket/system
"dirstruct.rkt"
"status.rkt"
(except-in "diff.rkt"
log-different?)
"path-utils.rkt"
"cache.rkt"
"config.rkt")
(define event-print
(match-lambda
[(struct stdout (bs))
(display bs) (newline)]
[(struct stdout (bs))
(display bs (current-error-port)) (newline)]))
(define (render-output-diff r1 r2 f)
(define l1 (status-output-log (read-cache (build-path (revision-log-dir r1) f))))
(define l2 (status-output-log (read-cache (build-path (revision-log-dir r2) f))))
(for ([d (in-list (render-log-difference l1 l2))])
(match d
[(struct difference (e1 e2))
(printf "! ")
(event-print e1)]
[(struct same-itude (e))
(printf " ")
(event-print e)])))
(command-line #:program "diffcmd"
#:args (rev1 rev2 filename)
(render-output-diff (string->number rev1)
(string->number rev2)
filename))

133
pkgs/plt-services/meta/drdr/dirstruct.rkt
View File

@ -1,133 +0,0 @@
#lang racket
(require "path-utils.rkt")
(define number-of-cpus
(make-parameter 1))
(define current-subprocess-timeout-seconds
(make-parameter (* 60 10)))
(define plt-directory
(make-parameter (build-path (current-directory))))
(define (plt-build-directory)
(build-path (plt-directory) "builds"))
(define (plt-future-build-directory)
(build-path (plt-directory) "future-builds"))
(define (plt-data-directory)
(build-path (plt-directory) "data"))
(define drdr-directory
(make-parameter (build-path (current-directory) "drdr")))
(define make-path
(make-parameter "/usr/bin/make"))
(define tar-path
(make-parameter "/bin/tar"))
(define Xvfb-path
(make-parameter "/usr/bin/Xvfb"))
(define fluxbox-path
(make-parameter "/usr/bin/fluxbox"))
(define vncviewer-path
(make-parameter "/usr/bin/vncviewer"))
(define (plt-repository)
(build-path (plt-directory) "repo"))
(define current-make-timeout-seconds
(make-parameter (* 60 30)))
(define current-make-install-timeout-seconds
(make-parameter (* 60 30)))
(define current-rev
(make-parameter #f))
(define previous-rev
(make-parameter #f))
(define (revision-dir rev)
(build-path (plt-build-directory) (number->string rev)))
(define (revision-log-dir rev)
(build-path (revision-dir rev) "logs"))
(define (revision-analyze-dir rev)
(build-path (revision-dir rev) "analyze"))
(define (revision-trunk-dir rev)
(build-path (revision-dir rev) "trunk"))
(define (revision-trunk.tgz rev)
(build-path (revision-dir rev) "trunk.tgz"))
(define (revision-trunk.tar.7z rev)
(build-path (revision-dir rev) "trunk.tar.7z"))
(define (revision-commit-msg rev)
(build-path (revision-dir rev) "commit-msg"))
(define (path->revision pth)
(define builds (explode-path (plt-build-directory)))
(define builds-len (length builds))
(define pths (explode-path pth))
(string->number (path->string* (list-ref pths builds-len))))
(define (revision-archive rev)
(build-path (revision-dir rev) "archive.db"))
(define (future-record-path n)
(build-path (plt-future-build-directory) (number->string n)))
(define (path-timing-log p)
(path-add-suffix (build-path (plt-data-directory) p) #".timing"))
(define (path-timing-png p)
(path-add-suffix (path-timing-log p) #".png"))
(define (path-timing-html p)
(path-add-suffix (path-timing-log p) #".html"))
(define (path-timing-png-prefix p)
(path-timing-log p))
(define build? (make-parameter #t))
(define (on-unix?)
(symbol=? 'unix (system-type 'os)))
(provide/contract
[current-subprocess-timeout-seconds (parameter/c exact-nonnegative-integer?)]
[number-of-cpus (parameter/c exact-nonnegative-integer?)]
[current-rev (parameter/c (or/c false/c exact-nonnegative-integer?))]
[previous-rev (parameter/c (or/c false/c exact-nonnegative-integer?))]
[plt-directory (parameter/c path-string?)]
[plt-build-directory (-> path?)]
[plt-data-directory (-> path?)]
[plt-future-build-directory (-> path?)]
[drdr-directory (parameter/c path-string?)]
[tar-path (parameter/c (or/c false/c string?))]
[make-path (parameter/c (or/c false/c string?))]
[Xvfb-path (parameter/c (or/c false/c string?))]
[vncviewer-path (parameter/c (or/c false/c string?))]
[fluxbox-path (parameter/c (or/c false/c string?))]
[build? (parameter/c boolean?)]
[on-unix? (-> boolean?)]
[plt-repository (-> path?)]
[path-timing-log (path-string? . -> . path?)]
[path-timing-png (path-string? . -> . path?)]
[path-timing-png-prefix (path-string? . -> . path?)]
[path-timing-html (path-string? . -> . path?)]
[future-record-path (exact-nonnegative-integer? . -> . path?)]
[current-make-timeout-seconds (parameter/c exact-nonnegative-integer?)]
[current-make-install-timeout-seconds (parameter/c exact-nonnegative-integer?)]
[revision-dir (exact-nonnegative-integer? . -> . path?)]
[revision-commit-msg (exact-nonnegative-integer? . -> . path?)]
[revision-log-dir (exact-nonnegative-integer? . -> . path?)]
[revision-analyze-dir (exact-nonnegative-integer? . -> . path-string?)]
[revision-trunk-dir (exact-nonnegative-integer? . -> . path?)]
[revision-trunk.tgz (exact-nonnegative-integer? . -> . path?)]
[revision-trunk.tar.7z (exact-nonnegative-integer? . -> . path?)]
[revision-archive (exact-nonnegative-integer? . -> . path?)]
[path->revision (path-string? . -> . exact-nonnegative-integer?)])

1799
pkgs/plt-services/meta/drdr/example.timing
View File

File diff suppressed because it is too large Load Diff

34
pkgs/plt-services/meta/drdr/formats.rkt
View File

@ -1,34 +0,0 @@
#lang racket
(define (formats v u)
(if (equal? v -inf.0)
"ε"
(with-handlers ([exn:fail? (lambda (x)
(format "~a~a"
(number->string v) u))])
(format "~a~a"
(real->decimal-string v 2) u))))
(define (format-duration-h h)
(formats h "h"))
(define (format-duration-m m)
(if (m . >= . 60)
(format-duration-h (/ m 60))
(formats m "m")))
(define (format-duration-s s)
(if (s . >= . 60)
(format-duration-m (/ s 60))
(formats s "s")))
(define (format-duration-ms ms)
(if (ms . >= . 1000)
(format-duration-s (/ ms 1000))
(formats ms "ms")))
(provide/contract
[formats (number? string? . -> . string?)]
[format-duration-h (number? . -> . string?)]
[format-duration-m (number? . -> . string?)]
[format-duration-s (number? . -> . string?)]
[format-duration-ms (number? . -> . string?)])

45
pkgs/plt-services/meta/drdr/good-init.sh
View File

@ -1,45 +0,0 @@
#!/bin/sh
export PLTSTDERR="info"
PLTROOT="/opt/plt/plt"
LOGS="/opt/plt/logs"
R="$PLTROOT/bin/racket"
DRDR="/opt/svn/drdr"
cd "$DRDR"
kill_all() {
cat "$LOGS/"*.pid > /tmp/leave-pids-$$
KILL=`pgrep '^(Xorg|Xnest|Xvfb|Xvnc|fluxbox|racket|gracket(-text)?)$' | grep -w -v -f /tmp/leave-pids-$$`
rm /tmp/leave-pids-$$
kill -15 $KILL
sleep 2
kill -9 $KILL
sleep 1
}
run_loop () { # <basename> <kill?>
while true; do
if [ "x$2" = "xyes" ]; then
echo "clearing unattached shm regions"
ipcs -ma | awk '0 == $6 {print $2}' | xargs -n 1 ipcrm -m
fi
echo "$1: compiling"
"$PLTROOT/bin/raco" make "$1.rkt"
echo "$1: running"
"$R" -t "$1.rkt" &
echo "$!" > "$LOGS/$1.pid"
wait "$!"
echo "$1: died"
rm "$LOGS/$1.pid"
if [ "x$2" = "xyes" ]; then
echo "killing processes"
kill_all
fi
done
}
exec
run_loop render &
run_loop main yes &

115
pkgs/plt-services/meta/drdr/house-call.rkt
View File

@ -1,115 +0,0 @@
#lang racket
(require racket/runtime-path
racket/date
"list-count.rkt"
"scm.rkt"
"formats.rkt"
"cache.rkt"
"metadata.rkt"
"analyze.rkt"
"rendering.rkt"
"plt-build.rkt"
"status.rkt"
"replay.rkt"
"notify.rkt"
"path-utils.rkt"
"dirstruct.rkt")
(build? #f)
(define show-log
(command-line #:program "house-call"
#:once-each
[("-j" "--jobs") jobs "How many processes to run simultaneously" (number-of-cpus (string->number jobs))]
["--build" "Build the source first" (build? #t)]
#:args log-to-view
log-to-view))
; Find paths we need
(define (path->string^ p)
(and p (path->string p)))
(git-path (path->string^ (find-executable-path "git")))
(Xvfb-path (and (on-unix?) (path->string^ (find-executable-path "Xvfb"))))
(fluxbox-path (and (on-unix?) (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 (make-file-or-directory-link* from to)
(unless (link-exists? to)
(make-file-or-directory-link from to)))
(define house-calls (build-path this-rev-dir "house-calls"))
(plt-directory house-calls)
(for ([d (in-list (list "builds" "future-builds" "data"))])
(make-directory* (build-path house-calls d)))
(make-file-or-directory-link* this-rev-dir (build-path house-calls "repo"))
(make-file-or-directory-link* this-rev-dir (build-path house-calls "plt"))
; Make up a revision and link it in
(define fake-rev (date->julian/scalinger (current-date)))
(current-rev fake-rev)
(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! "DrDr is making a house call...")
(integrate-revision fake-rev)
(define re (rebase-path (revision-log-dir fake-rev) "/"))
(define (print-lc label lc)
(define l (lc->list lc))
(unless (empty? l)
(printf "~a:\n" label)
(for ([bs (in-list l)])
(printf "\t~a\n"
(substring (path->string* (re (bytes->path bs))) 1)))
(newline)))
(match (analyze-logs fake-rev)
[(struct rendering (start end duration timeout unclean stderr _ _))
(print-lc "Timeout" timeout)
(print-lc "Unclean Exit" unclean)
(print-lc "STDERR Output" stderr)
(printf "Duration (Abs): ~a\n"
(format-duration-ms (- end start)))
(printf "Duration (Sum): ~a\n"
(format-duration-ms duration))]
[#f
(void)])
(for ([p (in-list show-log)])
(define lp (build-path (revision-log-dir fake-rev) p))
(match (read-cache lp)
[(? status? s)
(newline)
(printf "Replaying ~a:\n" p)
(printf "~a\n" (regexp-replace* #rx"<current-rev>" (apply string-append (add-between (status-command-line s) " ")) (number->string fake-rev)))
(replay-status s)]
[x
(printf "Could not get ~a's log; got: ~s\n" p x)]))

6
pkgs/plt-services/meta/drdr/info.rkt
View File

@ -1,6 +0,0 @@
#lang info
(define name "DrDr")
(define compile-omit-paths 'all)
(define test-responsibles '((all jay)))

413
pkgs/plt-services/meta/drdr/installed-software
View File

@ -1,413 +0,0 @@
adduser install
apparmor install
apparmor-utils install
apt install
apt-utils install
aptitude install
ash install
at install
autoconf install
automake install
autotools-dev install
base-files install
base-passwd install
bash install
bash-completion install
belocs-locales-bin install
bind9-host install
binutils install
binutils-static install
bsdmainutils install
bsdutils install
busybox-initramfs install
bzip2 install
ca-certificates install
command-not-found install
command-not-found-data install
console-setup install
console-terminus install
coreutils install
cpio install
cpp install
cpp-4.2 install
cpp-4.3 install
cron install
dash install
debconf install
debconf-i18n install
debianutils install
defoma install
dhcp3-client install
dhcp3-common install
diff install
dmidecode install
dmsetup install
dnsutils install
dosfstools install
dpkg install
e2fslibs install
e2fsprogs install
ed install
eject install
ethtool install
fdutils install
file install
findutils install
fontconfig install
fontconfig-config install
friendly-recovery install
ftp install
fuse-utils install
g++ install
g++-4.3 install
gcc install
gcc-4.2 install
gcc-4.2-base install
gcc-4.3 install
gcc-4.3-base install
gdb install
gettext-base install
gnupg install
gpgv install
grep install
groff-base install
grub install
gzip install
hdparm install
hostname install
ifupdown install
info install
initramfs-tools install
initscripts install
inputattach install
installation-report install
iproute install
iptables install
iputils-arping install
iputils-ping install
iputils-tracepath install
kbd install
klibc-utils install
klogd install
laptop-detect install
less install
libacl1 install
libapparmor-perl install
libapparmor1 install
libapr1 install
libaprutil1 install
libatm1 install
libattr1 install
libbind9-40 install
libblkid1 install
libbz2-1.0 install
libc6 install
libc6-dev install
libc6-i686 install
libcap1 install
libcap2 install
libck-connector0 install
libclass-accessor-perl install
libcomerr2 install
libcompress-raw-zlib-perl install
libcompress-zlib-perl install
libconsole install
libcurl3-gnutls install
libcwidget3 install
libdb4.6 install
libdb4.7 install
libdbus-1-3 install
libdevmapper1.02.1 install
libdns43 install
libdrm2 install
libedit2 install
libelf1 install
libelfg0 install
libept0 install
libexpat1 install
libfont-afm-perl install
libfontconfig1 install
libfontenc1 install
libfreetype6 install
libfribidi0 install
libfuse2 install
libgc1c2 install
libgcc1 install
libgcrypt11 install
libgdbm3 install
libgl1-mesa-dev install
libgl1-mesa-dri install
libgl1-mesa-glx install
libglu1-mesa install
libglu1-mesa-dev install
libgmp3c2 install
libgnutls26 install
libgomp1 install
libgpg-error0 install
libgpm2 install
libhal1 install
libhtml-format-perl install
libhtml-parser-perl install
libhtml-tagset-perl install
libhtml-template-perl install
libhtml-tree-perl install
libice-dev install
libice6 install
libidn11 install
libio-compress-base-perl install
libio-compress-zlib-perl install
libio-string-perl install
libisc44 install
libisccc40 install
libisccfg40 install
libiw29 install
libkeyutils1 install
libklibc install
libkrb53 install
libldap-2.4-2 install
liblocale-gettext-perl install
liblockfile1 install
libltdl7 install
libltdl7-dev install
liblwres40 install
liblzo2-2 install
libmagic1 install
libmailtools-perl install
libmpfr1ldbl install
libmysqlclient15off install
libncurses5 install
libncursesw5 install
libneon27-gnutls install
libnewt0.52 install
libntfs-3g28 install
libpam-modules install
libpam-runtime install
libpam0g install
libparse-debianchangelog-perl install
libparted1.8-9 install
libpcap0.8 install
libpci3 install
libpcre3 install
libpcre3-dev install
libpcrecpp0 install
libpcsclite1 install
libpixman-1-0 install
libpopt0 install
libpq5 install
libpthread-stubs0 install
libpthread-stubs0-dev install
libreadline5 install
librpc-xml-perl install
libsasl2-2 install
libsasl2-modules install
libselinux1 install
libsepol1 install
libsigc++-2.0-0c2a install
libslang2 install
libsm-dev install
libsm6 install
libsqlite3-0 install
libsqlite3-dev install
libss2 install
libssl0.9.8 install
libstdc++6 install
libstdc++6-4.3-dev install
libsvn1 install
libsysfs2 install
libtasn1-3 install
libterm-readkey-perl install
libtext-charwidth-perl install
libtext-iconv-perl install
libtext-wrapi18n-perl install
libtimedate-perl install
libtool install
liburi-perl install
libusb-0.1-4 install
libuuid1 install
libvolume-id0 install
libwrap0 install
libwww-perl install
libx11-6 install
libx11-data install
libx11-dev install
libxapian15 install
libxau-dev install
libxau6 install
libxaw7 install
libxaw7-dev install
libxcb-xlib0 install
libxcb-xlib0-dev install
libxcb1 install
libxcb1-dev install
libxdamage1 install
libxdmcp-dev install
libxdmcp6 install
libxext-dev install
libxext6 install
libxfixes3 install
libxfont1 install
libxi-dev install
libxi6 install
libxkbfile1 install
libxml-namespacesupport-perl install
libxml-parser-perl install
libxml-sax-expat-perl install
libxml-sax-perl install
libxml-simple-perl install
libxml2 install
libxmu-dev install
libxmu-headers install
libxmu6 install
libxmuu1 install
libxpm-dev install
libxpm4 install
libxt-dev install
libxt6 install
libxxf86vm1 install
links install
linux-firmware install
linux-image-2.6.24-19-server install
linux-image-2.6.27-14-server install
linux-image-server install
linux-libc-dev install
linux-restricted-modules-2.6.27-14-server install
linux-restricted-modules-common install
linux-restricted-modules-server install
linux-server install
linux-ubuntu-modules-2.6.24-19-server install
locales install
lockfile-progs install
login install
logrotate install
lsb-base install
lsb-release install
lshw install
lsof install
ltrace install
lzma install
m4 install
make install
makedev install
man-db install
manpages install
mawk install
memtest86+ install
mesa-common-dev install
mii-diag install
mime-support install
mktemp install
mlocate install
module-init-tools install
mount install
mtr-tiny install
mysql-common install
nano install
ncurses-base install
ncurses-bin install
net-tools install
netbase install
netcat install
netcat-traditional install
ntfs-3g install
ntp install
ntpdate install
openssh-blacklist install
openssh-client install
openssh-server install
openssl install
parted install
passwd install
pciutils install
pcmciautils install
perl install
perl-base install
perl-modules install
popularity-contest install
ppp install
pppconfig install
pppoeconf install
procmail install
procps install
psmisc install
python install
python-apt install
python-central install
python-gdbm install
python-gnupginterface install
python-minimal install
python-support install
python2.5 install
python2.5-minimal install
readline-common install
reiserfsprogs install
rsync install
sed install
sendmail install
sendmail-base install
sendmail-bin install
sendmail-cf install
sensible-mda install
sgml-base install
startup-tasks install
strace install
subversion install
sudo install
sysklogd install
system-services install
sysv-rc install
sysvinit-utils install
sysvutils install
tar install
tasksel install
tasksel-data install
tcpd install
tcpdump install
telnet install
time install
ttf-dejavu install
ttf-dejavu-core install
ttf-dejavu-extra install
ttf-xfree86-nonfree install
tzdata install
ubuntu-keyring install
ubuntu-minimal install
ubuntu-standard install
ucf install
udev install
ufw install
update-inetd install
update-manager-core install
upstart install
upstart-compat-sysv install
upstart-logd install
usbutils install
util-linux install
util-linux-locales install
uuid-runtime install
vim-common install
vim-tiny install
w3m install
wget install
whiptail install
wireless-tools install
wpasupplicant install
x-ttcidfont-conf install
x11-common install
x11-xkb-utils install
x11proto-core-dev install
x11proto-input-dev install
x11proto-kb-dev install
x11proto-xext-dev install
xauth install
xfonts-100dpi install
xfonts-75dpi install
xfonts-base install
xfonts-cyrillic install
xfonts-encodings install
xfonts-utils install
xkb-data install
xml-core install
xserver-common install
xtrans-dev install
xvfb install
zlib1g install

105
pkgs/plt-services/meta/drdr/job-queue.rkt
View File

@ -1,105 +0,0 @@
#lang racket/base
(require racket/list
racket/match
racket/local
racket/contract
racket/async-channel)
(define current-worker (make-parameter #f))
(define-struct job-queue (async-channel))
(define-struct job (paramz thunk))
(define-struct done ())
(define (make-queue how-many)
(define jobs-ch (make-async-channel))
(define work-ch (make-async-channel))
(define done-ch (make-async-channel))
(define (working-manager spaces accept-new? jobs continues)
(if (and (not accept-new?)
(empty? jobs)
(empty? continues))
(killing-manager how-many)
(apply
sync
(if (and accept-new?
(not (zero? spaces)))
(handle-evt
jobs-ch
(match-lambda
[(? job? the-job)
(working-manager (sub1 spaces) accept-new?
(list* the-job jobs) continues)]
[(? done?)
(working-manager spaces #f jobs continues)]))
never-evt)
(handle-evt
done-ch
(lambda (reply-ch)
(working-manager spaces accept-new?
jobs (list* reply-ch continues))))
(if (empty? jobs)
never-evt
(handle-evt
(async-channel-put-evt work-ch (first jobs))
(lambda (_)
(working-manager spaces accept-new?
(rest jobs) continues))))
(map
(lambda (reply-ch)
(handle-evt
(async-channel-put-evt reply-ch 'continue)
(lambda (_)
(working-manager (add1 spaces) accept-new?
jobs (remq reply-ch continues)))))
continues))))
(define (killing-manager left)
(unless (zero? left)
(sync
(handle-evt
done-ch
(lambda (reply-ch)
(async-channel-put reply-ch 'stop)
(killing-manager (sub1 left)))))))
(define (worker i)
(match (async-channel-get work-ch)
[(struct job (paramz thunk))
(call-with-parameterization
paramz
(lambda ()
(parameterize ([current-worker i])
(thunk))))
(local [(define reply-ch (make-async-channel))]
(async-channel-put done-ch reply-ch)
(local [(define reply-v (async-channel-get reply-ch))]
(case reply-v
[(continue) (worker i)]
[(stop) (void)]
[else
(error 'worker "Unknown reply command")])))]))
(define the-workers
(for/list ([i (in-range 0 how-many)])
(thread (lambda ()
(worker i)))))
(define the-manager
(thread (lambda () (working-manager how-many #t empty empty))))
(make-job-queue jobs-ch))
(define (submit-job! jobq thunk)
(async-channel-put
(job-queue-async-channel jobq)
(make-job (current-parameterization)
thunk)))
(define (stop-job-queue! jobq)
(async-channel-put
(job-queue-async-channel jobq)
(make-done)))
(provide/contract
[current-worker (parameter/c (or/c false/c exact-nonnegative-integer?))]
[job-queue? (any/c . -> . boolean?)]
[rename make-queue make-job-queue
(exact-nonnegative-integer? . -> . job-queue?)]
[submit-job! (job-queue? (-> any) . -> . void)]
[stop-job-queue! (job-queue? . -> . void)])

37
pkgs/plt-services/meta/drdr/list-count.rkt
View File

@ -1,37 +0,0 @@
#lang racket
(define list/count
(or/c exact-nonnegative-integer? (listof bytes?)))
(define lc->number
(match-lambda
[(? number? x)
x]
[(? list? x)
(length x)]))
(define lc->list
(match-lambda
[(? number? x)
empty]
[(? list? x)
x]))
(define lc-zero?
(match-lambda
[(? number? x)
(zero? x)]
[(? list? x)
(eq? empty x)]))
(define (lc+ x y)
(cond
[(number? x)
(+ x (lc->number y))]
[(number? y)
(+ (lc->number x) y)]
[else
(append x y)]))
(provide/contract
[list/count contract?]
[lc+ (list/count list/count . -> . list/count)]
[lc->number (list/count . -> . exact-nonnegative-integer?)]
[lc->list (list/count . -> . (listof bytes?))]
[lc-zero? (list/count . -> . boolean?)])

81
pkgs/plt-services/meta/drdr/main.rkt
View File

@ -1,81 +0,0 @@
#lang racket
(require racket/system
"dirstruct.rkt"
"analyze.rkt"
"monitor-scm.rkt"
"notify.rkt"
"retry.rkt"
"config.rkt"
"plt-build.rkt"
"scm.rkt"
"cache.rkt"
"path-utils.rkt")
(init-revisions!)
(define cur-rev (newest-revision))
(define prev-rev (second-newest-revision))
(define (handle-revision prev-rev cur-rev)
(define rev-dir (revision-dir cur-rev))
(parameterize ([current-rev cur-rev]
[previous-rev prev-rev])
(notify! "Removing future record for r~a" cur-rev)
(safely-delete-directory (future-record-path cur-rev))
(notify! "Starting to integrate revision r~a" cur-rev)
(integrate-revision cur-rev)
(notify! "Analyzing logs of r~a [prev: r~a]" cur-rev prev-rev)
(analyze-revision cur-rev)
(notify! "Recording timing data")
(cache/file/timestamp
(build-path rev-dir "timing-done")
(lambda ()
(system*/exit-code
(path->string
(build-path (plt-directory) "plt" "bin" "racket"))
"-t"
(path->string (build-path (drdr-directory) "time.rkt"))
"--"
"-r" (number->string cur-rev))))
(notify! "Recompressing")
(cache/file/timestamp
(build-path rev-dir "recompressing")
(lambda ()
(parameterize ([current-directory rev-dir])
(system*/exit-code
"/bin/bash"
(path->string
(build-path (drdr-directory) "recompress.sh"))))))
(notify! "Archiving old revisions")
(cache/file/timestamp
(build-path rev-dir "archiving-done")
(lambda ()
(system*/exit-code
(path->string
(build-path (plt-directory) "plt" "bin" "racket"))
"-t"
(path->string
(build-path (drdr-directory) "make-archive.rkt"))
"--"
"--many" (number->string 45))))))
(notify! "Last revision is r~a" cur-rev)
(handle-revision prev-rev cur-rev)
(notify! "Starting to monitor @ r~a" cur-rev)
(monitor-scm (plt-repository)
cur-rev
(lambda (newer)
(for ([rev (in-list newer)])
(write-cache!
(future-record-path rev)
(get-scm-commit-msg rev (plt-repository)))))
(lambda (prev-rev cur-rev)
(handle-revision prev-rev cur-rev)
;; We have problems running for a long time so just restart after each rev
(exit 0)))

23
pkgs/plt-services/meta/drdr/make-archive-lib.rkt
View File

@ -1,23 +0,0 @@
#lang racket
(require racket/system
"config.rkt"
"archive.rkt"
"path-utils.rkt"
"dirstruct.rkt")
(define (make-archive rev)
(define archive-path (revision-archive rev))
(if (file-exists? archive-path)
(begin (printf "r~a is already archived\n" rev)
#t)
(begin (local [(define tmp-path (make-temporary-file))]
(printf "Archiving r~a\n" rev)
(safely-delete-directory (revision-trunk.tgz rev))
(safely-delete-directory (revision-trunk.tar.7z rev))
(create-archive tmp-path (revision-dir rev))
(rename-file-or-directory tmp-path archive-path)
(safely-delete-directory (revision-log-dir rev))
(safely-delete-directory (revision-analyze-dir rev)))
#f)))
(provide make-archive)

26
pkgs/plt-services/meta/drdr/make-archive.rkt
View File

@ -1,26 +0,0 @@
#lang racket
(require racket/system
"config.rkt"
"archive.rkt"
"path-utils.rkt"
"dirstruct.rkt"
"make-archive-lib.rkt")
(define mode (make-parameter 'single))
(init-revisions!)
(command-line #:program "make-archive"
#:once-any
["--single" "Archive a single revision" (mode 'single)]
["--many" "Archive many revisions" (mode 'many)]
#:args (ns)
(local [(define n (string->number ns))]
(case (mode)
[(many)
(local [(define all-revisions
(sort revisions >=))]
(for/or ([rev (in-list (list-tail all-revisions n))])
(make-archive rev)))]
[(single)
(make-archive n)])))

77
pkgs/plt-services/meta/drdr/metadata.rkt
View File

@ -1,77 +0,0 @@
#lang racket
(require "path-utils.rkt"
"dirstruct.rkt"
"scm.rkt")
(define PROP:command-line "drdr:command-line")
(define PROP:timeout "drdr:timeout")
(define (path-command-line a-path a-timeout)
(define suffix (filename-extension a-path))
(define default-cmd
`(raco "test" "-m" "--timeout" ,(number->string a-timeout) *))
(define (replace-* s)
(cond
[(eq? '* s)
(path->string* a-path)]
[(not (string? s))
(format "~a" s)]
[else
s]))
(match (get-prop a-path 'drdr:command-line default-cmd)
[#f #f]
[(? list? l)
(cons (first l)
(map replace-* (rest l)))]))
(define (path-timeout a-path)
(get-prop a-path 'drdr:timeout #f))
(define (path-responsible a-path)
(get-prop a-path 'responsible #:as-string? #t))
(define (path-random? a-path)
(get-prop a-path 'drdr:random))
(provide/contract
[PROP:command-line string?]
[PROP:timeout string?]
[path-responsible
(path-string? . -> . (or/c string? false/c))]
[path-command-line
(-> path-string? exact-nonnegative-integer?
(or/c (cons/c symbol? (listof string?)) false/c))]
[path-random? (path-string? . -> . boolean?)]
[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))
(define a-path
(substring
(path->string
((rebase-path (revision-trunk-dir rev) "/") a-fs-path))
1))
(define props:get-prop
(hash-ref! props-cache rev
(lambda ()
(define tmp-file (make-temporary-file "props~a.rkt" #f (current-temporary-directory)))
(and
;; Checkout the props file
(scm-export-file
rev
(plt-repository)
"pkgs/plt-services/meta/props"
tmp-file)
;; Dynamic require it
(begin0
(with-handlers ([exn? (λ (x) #f)])
(dynamic-require `(file ,(path->string tmp-file))
'get-prop))
(delete-file tmp-file))))))
;; XXX get-prop is stupid and errors when a-path is invalid rather than returning def
(with-handlers ([exn? (lambda (x) def)])
(props:get-prop a-path prop def
#:as-string? as-string?)))

30
pkgs/plt-services/meta/drdr/monitor-drdr.rkt
View File

@ -1,30 +0,0 @@
#lang racket
(require xml
net/url
tests/web-server/util
"scm.rkt")
(define drdr-url
(string->url "http://drdr.racket-lang.org"))
(define drdr-xml
(call/input-url drdr-url get-pure-port read-xml/element))
(define drdr-xexpr
(xml->xexpr drdr-xml))
(define-values
(building done)
(for/fold ([building empty]
[done empty])
([tr (in-list (reverse (simple-xpath*/list '(tbody) drdr-xexpr)))])
(define rev (string->number (simple-xpath* '(a) tr)))
(define building? (simple-xpath* '(td #:class) tr))
(if building?
(values (list* rev building) done)
(values building (list* rev done)))))
(if (empty? building)
(if (= (first done) (newest-push))
(void)
(error 'monitor-drdr "DrDr is not building, but is not at the most recent push"))
(void))

37
pkgs/plt-services/meta/drdr/monitor-scm.rkt
View File

@ -1,37 +0,0 @@
#lang racket
(require "scm.rkt"
"retry.rkt")
(define current-monitoring-interval-seconds
(make-parameter 60))
(define (monitor-scm repos start-rev notify-newer! notify-user!)
(define (monitor-w/o-wait prev-rev)
(define new-revs
(scm-revisions-after prev-rev repos))
(match new-revs
[(list)
; There has not yet been more revisions
(monitor prev-rev)]
[(cons new-rev newer)
(scm-update repos)
; Notify of newer ones
(notify-newer! newer)
; There was a commit that we care about. Notify, then recur
(retry-until-success
(format "Notifying of revision ~a" new-rev)
(notify-user! prev-rev new-rev))
(monitor new-rev)]))
(define (monitor prev-rev)
(sleep (current-monitoring-interval-seconds))
(monitor-w/o-wait prev-rev))
(monitor-w/o-wait start-rev))
(provide/contract
[current-monitoring-interval-seconds
(parameter/c exact-nonnegative-integer?)]
[monitor-scm
(path-string? exact-nonnegative-integer?
((listof exact-nonnegative-integer?) . -> . void)
(exact-nonnegative-integer? exact-nonnegative-integer? . -> . void)
. -> . any)])

6
pkgs/plt-services/meta/drdr/notify.rkt
View File

@ -1,6 +0,0 @@
#lang racket
(define (notify! fmt . args)
(log-info (format "[~a] ~a" (current-seconds) (apply format fmt args))))
(provide/contract
[notify! ((string?) () #:rest (listof any/c) . ->* . void)])

54
pkgs/plt-services/meta/drdr/path-utils.rkt
View File

@ -1,54 +0,0 @@
#lang racket
(require racket/file)
(define current-temporary-directory
(make-parameter #f))
(define (directory-list->directory-list* l)
(sort (filter-not (compose
(lambda (s)
(or (regexp-match #rx"^\\." s)
(string=? "compiled" s)
(link-exists? s)))
path->string)
l)
string<=? #:key path->string #:cache-keys? #t))
(define (directory-list* pth)
(directory-list->directory-list* (directory-list pth)))
(define (safely-delete-directory pth)
(with-handlers ([exn:fail? (lambda (x) (void))])
(delete-directory/files pth)))
(define (make-parent-directory pth)
(define pth-dir (path-only pth))
(make-directory* pth-dir))
(define (write-to-file* v pth)
(define tpth (make-temporary-file))
(write-to-file v tpth #:exists 'truncate)
(make-parent-directory pth)
(rename-file-or-directory tpth pth #t))
(define (rebase-path from to)
(define froms (explode-path from))
(define froms-len (length froms))
(lambda (pth)
(define pths (explode-path pth))
(apply build-path to (list-tail pths froms-len))))
(define (path->string* pth-string)
(if (string? pth-string)
pth-string
(path->string pth-string)))
(provide/contract
[current-temporary-directory (parameter/c (or/c false/c path-string?))]
[safely-delete-directory (path-string? . -> . void)]
[directory-list->directory-list* ((listof path?) . -> . (listof path?))]
[directory-list* (path-string? . -> . (listof path?))]
[write-to-file* (any/c path-string? . -> . void)]
[make-parent-directory (path-string? . -> . void)]
[rebase-path (path-string? path-string? . -> . (path-string? . -> . path?))]
[path->string* (path-string? . -> . string?)])

439
pkgs/plt-services/meta/drdr/plt-build.rkt
View File

@ -1,439 +0,0 @@
#lang racket
(require racket/file
racket/runtime-path
"job-queue.rkt"
"metadata.rkt"
"run-collect.rkt"
"cache.rkt"
"dirstruct.rkt"
"replay.rkt"
"notify.rkt"
"path-utils.rkt"
"sema.rkt"
"scm.rkt")
(define current-env (make-parameter (make-immutable-hash empty)))
(define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...)
(parameterize ([current-env
(for/fold ([env (current-env)])
([k (in-list (list env-expr ...))]
[v (in-list (list val-expr ...))])
(hash-set env k v))])
expr ...))
(define (build-revision rev)
(define rev-dir (revision-dir rev))
(define co-dir (revision-trunk-dir rev))
(define log-dir (revision-log-dir rev))
(define trunk-dir (revision-trunk-dir rev))
;; Checkout the repository revision
(cache/file/timestamp
(build-path rev-dir "checkout-done")
(lambda ()
(notify! "Removing checkout directory: ~a" co-dir)
(safely-delete-directory co-dir)
(local [(define repo (plt-repository))
(define to-dir
(path->string co-dir))]
(notify! "Checking out ~a@~a into ~a"
repo rev to-dir)
(scm-export-repo rev repo to-dir))))
(parameterize ([current-directory co-dir])
(with-env
(["PLT_SETUP_OPTIONS" (format "-j ~a" (number-of-cpus))])
(run/collect/wait/log
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "pkg-src" "build" "make")
(make-path)
(list "-j" (number->string (number-of-cpus))))))
(run/collect/wait/log
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "pkg-src" "build" "archive")
(tar-path)
(list "-czvf"
(path->string (revision-trunk.tgz rev))
"-C" (path->string rev-dir)
"trunk")))
(define (call-with-temporary-directory thunk)
(define tempdir (symbol->string (gensym 'tmpdir)))
(dynamic-wind
(lambda ()
(make-directory* tempdir))
(lambda ()
(parameterize ([current-directory tempdir])
(thunk)))
(lambda ()
(delete-directory/files tempdir))))
(define-syntax-rule (with-temporary-directory e)
(call-with-temporary-directory (lambda () e)))
(define-syntax-rule
(define-with-temporary-planet-directory with-temporary-planet-directory env-str)
(begin
(define (call-with-temporary-planet-directory thunk)
(define tempdir
(build-path (current-directory)
(symbol->string (gensym 'planetdir))))
(dynamic-wind
(lambda ()
(make-directory* tempdir))
(lambda ()
(with-env ([env-str (path->string tempdir)])
(thunk)))
(lambda ()
(delete-directory/files tempdir))))
(define-syntax-rule (with-temporary-planet-directory e)
(call-with-temporary-planet-directory (lambda () e)))))
(define-with-temporary-planet-directory with-temporary-planet-directory "PLTPLANETDIR")
(define-with-temporary-planet-directory with-temporary-tmp-directory "TMPDIR")
(define (call-with-temporary-home-directory thunk)
(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)))
(lambda ()
(with-env (["HOME" (path->string new-dir)])
(thunk)))
(lambda ()
(delete-directory/files new-dir))))
(define-syntax-rule (with-temporary-home-directory e)
(call-with-temporary-home-directory (lambda () e)))
(define (with-running-program command args thunk)
(if command
(let ()
(define-values (new-command new-args)
(command+args+env->command+args
#:env (current-env)
command args))
(define-values
(the-process _stdout stdin _stderr)
(parameterize ([subprocess-group-enabled #t])
(apply subprocess
(current-error-port)
#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)
(eprintf "Killing parent because wrapper (~a) is dead...\n" (list* command args))
(kill-thread parent))))
;; Run without stdin
(close-output-port stdin)
(dynamic-wind
void
;; 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 #f)
(sleep)
(subprocess-kill the-process #t))))
(thunk)))
(define (tested-packages)
(define tmp-file (make-temporary-file "pkgs~a.rktd" #f (current-temporary-directory)))
;; Checkout the pkgs list
(scm-export-file (current-rev) (plt-repository) "pkgs/plt-services/meta/drdr/pkgs.rktd" tmp-file)
;; Read it in
(define val (file->value tmp-file))
(delete-file tmp-file))
(define (test-revision rev)
(define rev-dir (revision-dir rev))
(define trunk-dir
(revision-trunk-dir rev))
(define log-dir
(revision-log-dir rev))
(define trunk->log
(rebase-path trunk-dir log-dir))
(define racket-path
(path->string (build-path trunk-dir "racket" "bin" "racket")))
(define raco-path
(path->string (build-path trunk-dir "racket" "bin" "raco")))
;; XXX Remove
(define mzc-path
(path->string (build-path trunk-dir "racket" "bin" "mzc")))
(define gracket-path
(path->string (build-path trunk-dir "racket" "bin" "gracket")))
(define gui-workers (make-job-queue 1))
(define test-workers (make-job-queue (number-of-cpus)))
(define pkgs-pths
(list (build-path trunk-dir "racket" "collects")
(build-path trunk-dir "pkgs")
(build-path trunk-dir "racket" "share" "pkgs")))
(define (test-directory dir-pth upper-sema)
(define dir-log (build-path (trunk->log dir-pth) ".index.test"))
(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))
(define files
(sort files/unsorted <
#:key (λ (p)
(if (bytes=? #"tests" (path->bytes p))
0
1))
#:cache-keys? #t))
(for ([sub-pth (in-list files)])
(define pth (build-path dir-pth sub-pth))
(define directory? (directory-exists? pth))
(cond
[directory?
;; XXX do this in parallel?
(test-directory pth dir-sema)]
[else
(define log-pth (trunk->log pth))
(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 pth-timeout))
(define-values
(pth-cmd the-queue)
(match pth-cmd/general
[#f
(values #f #f)]
[(list-rest (or 'mzscheme 'racket) rst)
(values
(lambda (k)
(k (list* racket-path rst)))
test-workers)]
[(list-rest 'mzc rst)
(values
(lambda (k) (k (list* mzc-path rst)))
test-workers)]
[(list-rest 'raco rst)
(values
(lambda (k) (k (list* raco-path rst)))
test-workers)]
[(list-rest (or 'mred 'mred-text
'gracket 'gracket-text)
rst)
(values
(if (on-unix?)
(lambda (k)
(k
(list* gracket-path
"-display"
(format
":~a"
(cpu->child
(current-worker)))
rst)))
#f)
gui-workers)]
[_
(values #f #f)]))
(cond
[pth-cmd
(submit-job!
the-queue
(lambda ()
(dynamic-wind
void
(λ ()
(pth-cmd
(λ (l)
(with-env
(["DISPLAY"
(format ":~a"
(cpu->child
(current-worker)))])
(with-temporary-tmp-directory
(with-temporary-planet-directory
(with-temporary-home-directory
(with-temporary-directory
(run/collect/wait/log
log-pth
#:timeout pth-timeout
#:env (current-env)
(first l)
(rest l))))))))))
(λ ()
(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)))]))
;; Some setup
(for ([pp (in-list (tested-packages))])
(define (run name source)
(run/collect/wait/log
;; XXX Give it its own timeout
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "pkg" name)
raco-path
(list "pkg" "install" "--skip-installed" "-i" "--deps" "fail" "--name" name source)))
(match pp
[`(,name ,source) (run name source)]
[(? string? name) (run name name)]))
(run/collect/wait/log
#:timeout (current-subprocess-timeout-seconds)
#:env (current-env)
(build-path log-dir "pkg-src" "build" "set-browser.rkt")
racket-path
(list "-t"
(path->string*
(build-path (drdr-directory) "set-browser.rkt"))))
;; And go
(define (test-directories ps upper-sema)
(define list-sema (make-semaphore 0))
(define how-many
(for/sum ([p (in-list ps)] #:when (directory-exists? p))
(test-directory p list-sema)
1))
(and (not (zero? how-many))
(thread
(lambda ()
(semaphore-wait* list-sema how-many)
(semaphore-post upper-sema)))))
(define top-sema (make-semaphore 0))
(notify! "Starting testing")
(when (test-directories pkgs-pths top-sema)
(notify! "All testing scheduled... waiting for completion")
(sync
top-sema
(handle-evt
(alarm-evt
(+ (current-inexact-milliseconds)
(* 1000 (* 2 (current-make-install-timeout-seconds)))))
(λ _
(kill-thread (current-thread))))))
(notify! "Stopping testing")
(stop-job-queue! test-workers)
(stop-job-queue! gui-workers))
(define (recur-many i r f)
(if (zero? i)
(f)
(r (sub1 i) (lambda ()
(recur-many (sub1 i) r f)))))
(define XSERVER-OFFSET 20)
(define ROOTX XSERVER-OFFSET)
(define (cpu->child cpu-i)
ROOTX
#;
(+ XSERVER-OFFSET cpu-i 1))
(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)))))
(define (integrate-revision rev)
(define test-dir
(build-path (revision-dir rev) "test"))
(define planet-dir
(build-path test-dir "planet"))
(define home-dir
(build-path test-dir "home"))
(define tmp-dir
(build-path test-dir "tmp"))
(define lock-dir
(build-path test-dir "locks"))
(define trunk-dir
(revision-trunk-dir rev))
(cache/file/timestamp
(build-path (revision-dir rev) "integrated")
(lambda ()
(make-directory* test-dir)
(make-directory* planet-dir)
(make-directory* home-dir)
(make-directory* tmp-dir)
(make-directory* lock-dir)
;; We are running inside of a test directory so that random files are stored there
(parameterize ([current-directory test-dir]
[current-temporary-directory tmp-dir]
[current-rev rev])
(with-env (["PLTSTDERR" "error"]
["GIT_DIR" (path->string (plt-repository))]
["TMPDIR" (path->string tmp-dir)]
["PLTDRDR" "yes"]
["PATH"
(format "~a:~a"
(path->string
(build-path trunk-dir "bin"))
(getenv "PATH"))]
["PLTLOCKDIR" (path->string lock-dir)]
["PLTPLANETDIR" (path->string planet-dir)]
["HOME" (path->string home-dir)])
(unless (read-cache* (revision-commit-msg rev))
(write-cache! (revision-commit-msg rev)
(get-scm-commit-msg rev (plt-repository))))
(when (build?)
(build-revision rev))
(define (start-x-server i inner)
(notify! "Starting X server #~a" i)
(remove-X-locks tmp-dir i)
(with-running-program
"/usr/bin/Xorg" (list (format ":~a" i))
(lambda ()
(with-env
(["DISPLAY" (format ":~a" i)])
(sleep 2)
(notify! "Starting WM #~a" i)
(with-running-program
(fluxbox-path)
(list "-d" (format ":~a" i)
"--sm-disable"
"--no-composite")
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))))
(provide/contract
[integrate-revision (exact-nonnegative-integer? . -> . void)])

11
pkgs/plt-services/meta/drdr/recompress.sh
View File

@ -1,11 +0,0 @@
#!/bin/bash
unset a i
while IFS= read -r -d $'\0' file; do
newfile=$(dirname "${file}")/$(basename "${file}" .tgz).tar.7z
if [ -f "${newfile}" ] ; then
rm -f "${newfile}"
fi
7z x "${file}" -so | 7z a "${newfile}" -t7z -m0=lzma -mfb=64 -ms=on -mx=9 -si && rm -f ${file}
done < <(find . -name '*.tgz' -print0)

1116
pkgs/plt-services/meta/drdr/render.rkt
View File

File diff suppressed because it is too large Load Diff

18
pkgs/plt-services/meta/drdr/rendering.rkt
View File

@ -1,18 +0,0 @@
#lang racket
(require "list-count.rkt")
(define-struct rendering (start end duration timeout? unclean-exit? stderr? responsible changed?) #:prefab)
(define (rendering-responsibles r)
(regexp-split #rx"," (rendering-responsible r)))
(provide/contract
[struct rendering ([start number?]
[end number?]
[duration number?]
[timeout? list/count]
[unclean-exit? list/count]
[stderr? list/count]
[responsible string?]
[changed? list/count])]
[rendering-responsibles (rendering? . -> . (listof string?))])

21
pkgs/plt-services/meta/drdr/replay-log.rkt
View File

@ -1,21 +0,0 @@
#lang racket
(require "replay.rkt"
"cache.rkt"
"status.rkt")
; XXX Rewrite to work with logs in dbm
(define the-log-file
(command-line
#:program "replay-log"
#:args (filename)
filename))
(define the-log
(read-cache the-log-file))
(unless (status? the-log)
(error 'replay-log "Not an output log: ~e" the-log))
(replay-status the-log)
(replay-exit-code the-log)

27
pkgs/plt-services/meta/drdr/replay.rkt
View File

@ -1,27 +0,0 @@
#lang racket
(require (prefix-in racket: racket)
"formats.rkt"
"status.rkt")
(define replay-event
(match-lambda
[(struct stdout (bs)) (printf "~a\n" bs)]
[(struct stderr (bs)) (eprintf "~a\n" bs)]))
(define (replay-status s)
(for-each replay-event (status-output-log s))
#;(when (timeout? s)
(eprintf "[replay-log] TIMEOUT!\n"))
#;(when (exit? s)
(eprintf "[replay-log] Exit code: ~a\n" (exit-code s)))
#;(printf "[replay-log] Took ~a\n"
(format-duration-ms (status-duration s)))
(replay-exit-code s))
(define (replay-exit-code s)
(when (exit? s)
(racket:exit (exit-code s))))
(provide/contract
[replay-exit-code (status? . -> . void)]
[replay-status (status? . -> . void)])

16
pkgs/plt-services/meta/drdr/retry.rkt
View File

@ -1,16 +0,0 @@
#lang racket
(require "notify.rkt")
(define-syntax-rule (retry-until-success msg expr ...)
(retry-until-success* msg (lambda () expr ...)))
(define (retry-until-success* msg thunk)
(notify! msg)
(thunk)
#;(with-handlers ([exn:fail? (lambda (x)
((error-display-handler) (format "Error trying to: ~a: ~a" msg (exn-message x)) x)
(notify! "Retrying...")
(retry-until-success* msg thunk))])
(thunk)))
(provide retry-until-success)

31
pkgs/plt-services/meta/drdr/rewriting.rkt
View File

@ -1,31 +0,0 @@
#lang racket
(require "status.rkt")
(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 #: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 b))]
[(struct stderr (b)) (make-stderr (rewrite-bytes b))]))
(define rewrite-string/c
((or/c string? bytes?) . -> . (or/c string? bytes?)))
(provide/contract
[rewrite-string/c contract?]
[rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)])

163
pkgs/plt-services/meta/drdr/run-collect.rkt
View File

@ -1,163 +0,0 @@
#lang racket
(require "status.rkt"
"notify.rkt"
"rewriting.rkt"
"dirstruct.rkt"
"cache.rkt")
(define (command+args+env->command+args
#:env env
cmd args)
(values "/usr/bin/env"
(append (for/list ([(k v) (in-hash env)])
(format "~a=~a" k v))
(list* cmd
args))))
(define (run/collect/wait
#:env env
#:timeout timeout
command args)
(define start-time
(current-inexact-milliseconds))
; Run the command
(define-values (new-command new-args)
(command+args+env->command+args
#:env env
command args))
(define command-line
(list* command args))
(define-values
(the-process stdout stdin stderr)
(parameterize ([subprocess-group-enabled #t])
(apply subprocess
#f #f #f
new-command
new-args)))
(notify! "Running: ~a ~S" command args)
; Run it without input
(close-output-port stdin)
; Wait for all the output and the process death or timeout
(local
[(define the-alarm
(alarm-evt (+ start-time (* 1000 timeout))))
(define line-ch (make-channel))
(define (read-port-t make port)
(thread
(λ ()
(let loop ()
(define l (read-bytes-line port))
(if (eof-object? l)
(channel-put line-ch l)
(begin (channel-put line-ch (make l))
(loop)))))))
(define stdout-t (read-port-t make-stdout stdout))
(define stderr-t (read-port-t make-stderr stderr))
(define final-status
(let loop ([open-ports 2]
[end-time #f]
[status #f]
[log empty])
(define process-done? (and end-time #t))
(define output-done? (zero? open-ports))
(if (and output-done? process-done?)
(if status
(if (= status 2)
(make-timeout start-time end-time command-line (reverse log))
(make-exit start-time end-time command-line (reverse log) status))
(make-timeout start-time end-time command-line (reverse log)))
(sync (if process-done?
never-evt
(choice-evt
(handle-evt the-alarm
(λ (_)
(define end-time
(current-inexact-milliseconds))
(subprocess-kill the-process #f)
;; Sleep for 10% of the timeout
;; before sending the death
;; signal
(sleep (* timeout 0.1))
(subprocess-kill the-process #t)
(loop open-ports end-time status log)))
(handle-evt the-process
(λ (_)
(define end-time
(current-inexact-milliseconds))
(loop open-ports end-time (subprocess-status the-process) log)))))
(if output-done?
never-evt
(handle-evt line-ch
(match-lambda
[(? eof-object?)
(loop (sub1 open-ports) end-time status log)]
[l
(loop open-ports end-time status (list* l log))])))))))]
(close-input-port stdout)
(close-input-port stderr)
(notify! "Done: ~a ~S" command args)
final-status))
(define-syntax regexp-replace**
(syntax-rules ()
[(_ () s) s]
[(_ ([pat0 subst0]
[pat subst]
...)
s)
(regexp-replace* (regexp-quote pat0)
(regexp-replace** ([pat subst] ...) s)
subst0)]))
(define (run/collect/wait/log log-path command
#:timeout timeout
#:env env
args)
(define ran? #f)
(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>"]
[tmp "<tmp>"]
[home "<home>"]
[cwd "<cwd>"])
s))
(set! ran? #t)
(rewrite-status
#:rewrite rewrite
(run/collect/wait
#:timeout timeout
#:env env
command args))))
ran?)
(provide/contract
[command+args+env->command+args
(string? (listof string?) #:env (hash/c string? string?) . -> . (values string? (listof string?)))]
[run/collect/wait
(string?
#:env (hash/c string? string?)
#:timeout exact-nonnegative-integer?
(listof string?)
. -> . status?)]
[run/collect/wait/log
(path-string? string?
#:env (hash/c string? string?)
#:timeout exact-nonnegative-integer?
(listof string?)
. -> . boolean?)])

294
pkgs/plt-services/meta/drdr/scm.rkt
View File

@ -1,294 +0,0 @@
#lang racket
(require "svn.rkt"
"path-utils.rkt"
"dirstruct.rkt"
net/url
racket/system)
(provide
(all-from-out "svn.rkt"))
(define git-path (make-parameter "/opt/local/bin/git"))
(provide/contract
[git-path (parameter/c string?)])
(define git-url-base "http://git.racket-lang.org/plt.git")
(provide/contract
[newest-push (-> number?)])
(define (newest-push)
(string->number (port->string (get-pure-port (string->url (format "~a/push-counter" git-url-base))))))
(define (pad2zeros n)
(format "~a~a"
(if (n . < . 10)
"0" "")
(number->string n)))
(define-struct push-data (who end-commit branches) #:prefab)
(define (push-info push-n)
(define push-n100s (quotient push-n 100))
(define push-nrem (pad2zeros (modulo push-n 100)))
(define ls
(port->lines
(get-pure-port
(string->url
(format "~a/pushes/~a/~a" git-url-base push-n100s push-nrem)))))
(match
ls
[(list (regexp #rx"^([^ ]+) +([0-9abcdef]+)$" (list _ who end-commit))
(regexp #rx"^([0-9abcdef]+) +([0-9abcdef]+) +(.+)$" (list _ bstart bend branch)))
(make-push-data who bend
(make-immutable-hash
(list (cons branch (vector bstart bend)))))]
[(list (regexp #rx"^([^ ]+) +([0-9abcdef]+)$" (list _ who end-commit))
(regexp #rx"^([0-9abcdef]+) +([0-9abcdef]+) +(.+)$" (list _ bstart bend branch))
...)
(make-push-data who end-commit
(make-immutable-hash
(map (lambda (b bs be) (cons b (vector bs be)))
branch bstart bend)))]
[_
#f]))
(define (pipe/proc cmds)
(if (null? (cdr cmds))
((car cmds))
(let-values ([(i o) (make-pipe 4096)])
(parameterize ([current-output-port o])
(thread (lambda () ((car cmds)) (close-output-port o))))
(parameterize ([current-input-port i])
(pipe/proc (cdr cmds))))))
(define-syntax-rule (pipe expr exprs ...)
(pipe/proc (list (lambda () expr) (lambda () exprs) ...)))
(define (close-input-port* p)
(when p (close-input-port p)))
(define (close-output-port* p)
(when p (close-output-port p)))
(define (system/output-port #:k k #:stdout [init-stdout #f] . as)
(define-values (sp stdout stdin stderr)
(apply subprocess init-stdout #f #f as))
(begin0 (k stdout)
(subprocess-wait sp)
(subprocess-kill sp #t)
(close-input-port* stdout)
(close-output-port* stdin)
(close-input-port* stderr)))
(define-struct git-push (num author commits) #:prefab)
(define-struct git-commit (hash author date msg) #:prefab)
(define-struct (git-diff git-commit) (mfiles) #:prefab)
(define-struct (git-merge git-commit) (from to) #:prefab)
(define-struct git-commit* (branch hash author date msg) #:prefab)
(define-struct (git-diff* git-commit*) (mfiles) #:prefab)
(define-struct (git-merge* git-commit*) (from to) #:prefab)
(define (read-until-empty-line in-p)
(let loop ()
(let ([l (read-line in-p)])
(cond
[(eof-object? l)
(close-input-port in-p)
empty]
[(string=? l "")
empty]
[else
(list* (regexp-replace #rx"^ +" l "") (loop))]))))
(define (read-commit branch in-p)
(match (read-line in-p)
[(? eof-object?)
#f]
[(regexp #rx"^commit +(.+)$" (list _ hash))
(match (read-line in-p)
[(regexp #rx"^Merge: +(.+) +(.+)$" (list _ from to))
(match-define (regexp #rx"^Author: +(.+)$" (list _ author)) (read-line in-p))
(match-define (regexp #rx"^Date: +(.+)$" (list _ date)) (read-line in-p))
(define _1 (read-line in-p))
(define msg (read-until-empty-line in-p))
(make-git-merge* branch hash author date msg from to)]
[(regexp #rx"^Author: +(.+)$" (list _ author))
(match-define (regexp #rx"^Date: +(.+)$" (list _ date)) (read-line in-p))
(define _1 (read-line in-p))
(define msg (read-until-empty-line in-p))
(define mfiles (read-until-empty-line in-p))
(make-git-diff* branch hash author date msg mfiles)])]))
(define port-empty? port-closed?)
(define (read-commits branch in-p)
(cond
[(port-empty? in-p)
empty]
[(read-commit branch in-p)
=> (lambda (c)
(printf "~S\n" c)
(list* c (read-commits branch in-p)))]
[else
empty]))
(define (get-scm-commit-msg rev repo)
(match-define (struct push-data (who _ branches)) (push-info rev))
(make-git-push
rev who
(apply append
(for/list
([(branch cs) branches])
(match-define (vector start-commit end-commit) cs)
(parameterize
([current-directory repo])
(system/output-port
#:k (curry read-commits branch)
(git-path)
"--no-pager" "log" "--date=iso" "--name-only" "--no-merges"
(format "~a..~a" start-commit end-commit)))))))
(provide/contract
[struct git-push
([num exact-nonnegative-integer?]
[author string?]
[commits (listof (or/c git-commit? git-commit*?))])]
[struct git-commit
([hash string?]
[author string?]
[date string?]
[msg (listof string?)])]
[struct git-diff
([hash string?]
[author string?]
[date string?]
[msg (listof string?)]
[mfiles (listof string?)])]
[struct git-merge
([hash string?]
[author string?]
[date string?]
[msg (listof string?)]
[from string?]
[to string?])]
[struct git-commit*
([branch string?]
[hash string?]
[author string?]
[date string?]
[msg (listof string?)])]
[struct git-diff*
([branch string?]
[hash string?]
[author string?]
[date string?]
[msg (listof string?)]
[mfiles (listof string?)])]
[struct git-merge*
([branch string?]
[hash string?]
[author string?]
[date string?]
[msg (listof string?)]
[from string?]
[to string?])]
[get-scm-commit-msg (exact-nonnegative-integer? path-string? . -> . git-push?)])
(define (git-commit-msg* gc)
(if (git-commit? gc)
(git-commit-msg gc)
(git-commit*-msg gc)))
(define (git-commit-hash* gc)
(if (git-commit? gc)
(git-commit-hash gc)
(git-commit*-hash gc)))
(provide/contract
[git-commit-hash* (-> (or/c git-commit? git-commit*?) string?)]
[git-commit-msg* (-> (or/c git-commit? git-commit*?) (listof string?))])
(define (git-push-previous-commit gp)
(define start (git-push-start-commit gp))
(parameterize ([current-directory (plt-repository)])
(system/output-port
#:k (λ (port) (read-line port))
(git-path)
"--no-pager" "log" "--format=format:%P" start "-1")))
(define (git-push-start-commit gp)
(define cs (git-push-commits gp))
(if (empty? cs)
"xxxxxxxxxxxxxxxxxxxxxxxxx"
(git-commit-hash* (last cs))))
(define (git-push-end-commit gp)
(define cs (git-push-commits gp))
(if (empty? cs)
"xxxxxxxxxxxxxxxxxxxxxxxxx"
(git-commit-hash* (first cs))))
(provide/contract
[git-push-previous-commit (git-push? . -> . string?)]
[git-push-start-commit (git-push? . -> . string?)]
[git-push-end-commit (git-push? . -> . string?)])
(define scm-commit-author
(match-lambda
[(? git-push? gp) (git-push-author gp)]
[(? svn-rev-log? srl) (svn-rev-log-author srl)]))
(provide/contract
[scm-commit-author ((or/c git-push? svn-rev-log?) . -> . string?)])
(define (scm-export-file rev repo file dest)
(define commit
(push-data-end-commit (push-info rev)))
(call-with-output-file*
dest
#:exists 'truncate/replace
(lambda (file-port)
(parameterize ([current-directory repo])
(system/output-port
#:k void
#:stdout file-port
(git-path) "--no-pager" "show" (format "~a:~a" commit file)))))
(void))
(define (scm-export-repo rev repo dest)
(define end (push-data-end-commit (push-info rev)))
(printf "Exporting ~v where end = ~a\n"
(list rev repo dest)
end)
(pipe
(parameterize ([current-directory repo])
(system*
(git-path) "archive"
(format "--prefix=~a/"
(regexp-replace #rx"/+$" (path->string* dest) ""))
"--format=tar"
end))
(system* (find-executable-path "tar") "xf" "-" "--absolute-names"))
(void))
(define (scm-update repo)
(parameterize ([current-directory repo])
(system* (git-path) "fetch"))
(void))
(define master-branch "refs/heads/master")
(define release-branch "refs/heads/release")
(define (contains-drdr-request? p)
(for*/or ([c (in-list (git-push-commits p))]
[m (in-list (git-commit-msg* c))])
(regexp-match #rx"DrDr, test this push" m)))
(define (scm-revisions-after cur-rev repo)
(define newest-rev (newest-push))
(for/list ([rev (in-range (add1 cur-rev) (add1 newest-rev))]
#:when
(let ([info (push-info rev)])
(and info
(or (hash-has-key? (push-data-branches info) master-branch)
(hash-has-key? (push-data-branches info) release-branch)
(contains-drdr-request? (get-scm-commit-msg rev repo))))))
rev))
(provide/contract
[scm-update (path? . -> . void?)]
[scm-revisions-after (exact-nonnegative-integer? path-string? . -> . (listof exact-nonnegative-integer?))]
[scm-export-file (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)]
[scm-export-repo (exact-nonnegative-integer? path-string? path-string? . -> . void?)])

9
pkgs/plt-services/meta/drdr/sema.rkt
View File

@ -1,9 +0,0 @@
#lang racket
(define (semaphore-wait* sema how-many)
(unless (zero? how-many)
(semaphore-wait sema)
(semaphore-wait* sema (sub1 how-many))))
(provide/contract
[semaphore-wait* (semaphore? exact-nonnegative-integer? . -> . void)])

8
pkgs/plt-services/meta/drdr/set-browser.rkt
View File

@ -1,8 +0,0 @@
#lang racket
(printf "Setting the default browser to something safe...\n")
; XXX maybe have it call /quit
(put-preferences
'(external-browser)
'(("echo " . "")))

256
pkgs/plt-services/meta/drdr/static/chart.js
View File

@ -1,256 +0,0 @@
var path = ""
var data = null;
var sub_times = [];
var overall_times = [];
var chart_data = [];
var show_hide = {}
var options = { selection: { mode: "xy" },
legend: { backgroundOpacity: 0,
position: "sw",
show: true,
noColumns : 1,
labelFormatter :
function(label, series) {
if (show_hide[label] === undefined)
show_hide[label] = true;
var css = '';
if (!show_hide[label]) {
css = 'style="font-style: italic"';
}
var v = '<div '+css+' onclick="legend_click(\''+label+'\')">' + label + '</div>';
return v;}},
xaxes: [{min: null, max: null, label: 'push'}],
yaxes: [{min: null, max: null, label: "time"},
{position: "right"}],
grid: { clickable: true, hoverable : true }
};
function addCommas(nStr) {
var rgx = /(\d+)(\d{3})/;
while (rgx.test(nStr)) {
nStr = nStr.replace(rgx, '$1' + ',' + '$2');
}
return nStr;
}
// Number -> String
function format_ms(ms) {
return addCommas(String(ms)) + " ms"
}
// Number -> String
function format_time(ms) {
if (ms >= 300000)
return Number(ms/60000).toFixed(2) + " m " + "("+ format_ms(ms)+")";
if (ms >= 10000)
return Number(ms/1000).toFixed(2) + " s" + "("+ format_ms(ms)+")";
return format_ms(ms);
}
function legend_click(l) {
show_hide[l] = !show_hide[l];
show();
serialize_opts(options);
}
var placeholder = $("#_chart");
var previousPoint = null;
function showTooltip(x, y, contents) {
$('<div id="tooltip">' + contents + '</div>').css( {
position: 'absolute',
display: 'none',
top: y + 5,
left: x + 5,
border: '1px solid #fdd',
padding: '2px',
'background-color': '#fee',
opacity: 0.80
}).appendTo("body").fadeIn(200);
}
function makeTooltip(item,path) {
var x = item.datapoint[0];
var y = item.datapoint[1].toFixed(2);
showTooltip(item.pageX, item.pageY,
item.series.label + ' at <a href="http://drdr.racket-lang.org/'
+ x + path + '">push ' + x + "</a>: "
+ format_time(y));
}
placeholder.bind("plotselected", handle_selection);
// is the tooltip shown b/c of a click?
var tooltip_clicked = false;
function remove_tooltip() {
tooltip_clicked = false;
$("#tooltip").remove();
}
function hover(event,pos,item) {
if (tooltip_clicked) return;
if (item) {
// don't re-show the same tool-tip that's already shown
if (previousPoint != item.dataIndex) {
previousPoint = item.dataIndex;
remove_tooltip();
makeTooltip(item,path);
}
}
else {
remove_tooltip();
previousPoint = null;
}
}
function click(e,pos,item) {
if (tooltip_clicked) {
remove_tooltip();
return;
}
if (!item) return;
tooltip_clicked = true;
// if we've already got the tooltip, just keep it around
if (previousPoint != item.dataIndex) {
$("#tooltip").remove();
makeTooltip(item,path);
}
}
// sort chart data based on the order of a[0], b[0]
function sorter(a,b) {
if (a[0] < b[0]) return -1;
if (a[0] > b[0]) return 1;
return 0;
}
function load_data(d) {
chart_data = [];
overall_times = [];
sub_times = [];
pdata = []
data = d;
reset_chart();
pdata = data && JSON.parse(data);
var max_overall = 0;
var max_sub = 0;
// build the timing data arrays
for (var i = 0; i < pdata.length; i++) {
overall_times.push([pdata[i][0], pdata[i][1]]);
max_overall = Math.max(max_overall, pdata[i][1]);
if (pdata[i][2].length != 0) {
for (var j = 0; j < pdata[i][2].length; j++) {
sub_times[j] = sub_times[j] || [];
sub_times[j].push([pdata[i][0],pdata[i][2][j][0]]);
max_sub = Math.max(max_sub, pdata[i][2][j][0]);
}
}
};
// is there a significant difference between the overall times
// and the internal timings?
var ya = 1;
if ((max_overall > (5 * max_sub)) || ((max_overall * 5) < max_sub))
ya = 2;
// put the data into the chart format
chart_data.push({data: overall_times.sort(sorter), label: "Overall Time", color: "#804040"});
for(var i = 0; i < sub_times.length; i++) {
var n = (sub_times[i].length/overall_times.length);
chart_data.push({data: sub_times[i].sort(sorter), label: "Timer "+ (i+1),
lines: { show: (.9<n) },
points: { show: !(.9<n) },
yaxis: ya});
}
cur_options.legend.noColumns = Math.max(1,Math.round(chart_data.length / 10));
}
function get_data(_path) {
if (_path[0] != '/')
_path = '/' + _path;
path = _path;
$.ajax({url: 'http://drdr.racket-lang.org/json/timing'+path,
beforeSend: function(xhr) {
xhr.overrideMimeType( 'text/plain; charset=x-user-defined' );
},
success: function(d) { load_data(d); show(); }});
}
function show() {
for(var i = 0; i < chart_data.length; i++) {
if (show_hide[chart_data[i].label] === false) {
if (!chart_data[i].saved)
chart_data[i].saved = chart_data[i].data
chart_data[i].data = [];
}
else if (chart_data[i].data.length === 0 && chart_data[i].saved !== null) {
chart_data[i].data = chart_data[i].saved;
chart_data[i].saved = null;
}
}
$.plot(placeholder, chart_data, cur_options);
}
function serialize_opts(options) {
var o = {};
if (options.xaxes[0].min)
o.xmin = options.xaxes[0].min;
if (options.xaxes[0].max)
o.xmax = options.xaxes[0].max;
if (options.yaxes[0].min)
o.ymin = options.yaxes[0].min;
if (options.yaxes[0].max)
o.ymax = options.yaxes[0].max;
window.location.hash = "#" + (JSON.stringify([o,show_hide]));
}
function handle_selection(event, ranges) {
cur_options = $.extend(true, {}, cur_options, {
yaxes: [ { min: ranges.yaxis.from, max: ranges.yaxis.to },cur_options.yaxes[1]],
xaxes: [ { min: ranges.xaxis.from, max: ranges.xaxis.to } ]});
serialize_opts(cur_options);
show();
}
function set_legend(new_val) {
cur_options = $.extend(true,{},cur_options, {legend: {show: new_val}});
show();
if (new_val)
$("#setlegend").text("Hide Legend")
else
$("#setlegend").text("Show Legend")
}
function reset_chart() {
cur_options = options; show_hide = {}; show();
}
placeholder.bind("plothover", hover);
placeholder.bind("plotclick", click);
var opts = {xmin : null, ymin: null, xmax: null, ymax : null};
var cur_options = options;
try {
opts = JSON.parse(window.location.hash.substring(1));
} catch(e) {}
if (opts && opts.length == 2) {
cur_options.xaxes[0].min = opts[0].xmin;
cur_options.xaxes[0].max = opts[0].xmax;
cur_options.yaxes[0].min = opts[0].ymin;
cur_options.yaxes[0].max = opts[0].ymax;
for(i in opts[1]) {
console.log(i,opts[1][i]);
show_hide[i] = opts[1][i];
}
}

BIN
pkgs/plt-services/meta/drdr/static/graph-images/after.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 310 B

BIN
pkgs/plt-services/meta/drdr/static/graph-images/before.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 305 B

BIN
pkgs/plt-services/meta/drdr/static/graph-images/dot.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 70 B

BIN
pkgs/plt-services/meta/drdr/static/images/fast-forward-change.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.4 KiB

BIN
pkgs/plt-services/meta/drdr/static/images/fast-forward.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.3 KiB

BIN
pkgs/plt-services/meta/drdr/static/images/rewind-change.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.4 KiB

BIN
pkgs/plt-services/meta/drdr/static/images/rewind.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.3 KiB

BIN
pkgs/plt-services/meta/drdr/static/images/skip-backward1.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.2 KiB

BIN
pkgs/plt-services/meta/drdr/static/images/skip-forward1.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.2 KiB

18
pkgs/plt-services/meta/drdr/static/jquery-1.6.2.min.js vendored
View File

File diff suppressed because one or more lines are too long

2599
pkgs/plt-services/meta/drdr/static/jquery.flot.js
View File

File diff suppressed because it is too large Load Diff

344
pkgs/plt-services/meta/drdr/static/jquery.flot.selection.js
View File

@ -1,344 +0,0 @@
/*
Flot plugin for selecting regions.
The plugin defines the following options:
selection: {
mode: null or "x" or "y" or "xy",
color: color
}
Selection support is enabled by setting the mode to one of "x", "y" or
"xy". In "x" mode, the user will only be able to specify the x range,
similarly for "y" mode. For "xy", the selection becomes a rectangle
where both ranges can be specified. "color" is color of the selection
(if you need to change the color later on, you can get to it with
plot.getOptions().selection.color).
When selection support is enabled, a "plotselected" event will be
emitted on the DOM element you passed into the plot function. The
event handler gets a parameter with the ranges selected on the axes,
like this:
placeholder.bind("plotselected", function(event, ranges) {
alert("You selected " + ranges.xaxis.from + " to " + ranges.xaxis.to)
// similar for yaxis - with multiple axes, the extra ones are in
// x2axis, x3axis, ...
});
The "plotselected" event is only fired when the user has finished
making the selection. A "plotselecting" event is fired during the
process with the same parameters as the "plotselected" event, in case
you want to know what's happening while it's happening,
A "plotunselected" event with no arguments is emitted when the user
clicks the mouse to remove the selection.
The plugin allso adds the following methods to the plot object:
- setSelection(ranges, preventEvent)
Set the selection rectangle. The passed in ranges is on the same
form as returned in the "plotselected" event. If the selection mode
is "x", you should put in either an xaxis range, if the mode is "y"
you need to put in an yaxis range and both xaxis and yaxis if the
selection mode is "xy", like this:
setSelection({ xaxis: { from: 0, to: 10 }, yaxis: { from: 40, to: 60 } });
setSelection will trigger the "plotselected" event when called. If
you don't want that to happen, e.g. if you're inside a
"plotselected" handler, pass true as the second parameter. If you
are using multiple axes, you can specify the ranges on any of those,
e.g. as x2axis/x3axis/... instead of xaxis, the plugin picks the
first one it sees.
- clearSelection(preventEvent)
Clear the selection rectangle. Pass in true to avoid getting a
"plotunselected" event.
- getSelection()
Returns the current selection in the same format as the
"plotselected" event. If there's currently no selection, the
function returns null.
*/
(function ($) {
function init(plot) {
var selection = {
first: { x: -1, y: -1}, second: { x: -1, y: -1},
show: false,
active: false
};
// FIXME: The drag handling implemented here should be
// abstracted out, there's some similar code from a library in
// the navigation plugin, this should be massaged a bit to fit
// the Flot cases here better and reused. Doing this would
// make this plugin much slimmer.
var savedhandlers = {};
var mouseUpHandler = null;
function onMouseMove(e) {
if (selection.active) {
updateSelection(e);
plot.getPlaceholder().trigger("plotselecting", [ getSelection() ]);
}
}
function onMouseDown(e) {
if (e.which != 1) // only accept left-click
return;
// cancel out any text selections
document.body.focus();
// prevent text selection and drag in old-school browsers
if (document.onselectstart !== undefined && savedhandlers.onselectstart == null) {
savedhandlers.onselectstart = document.onselectstart;
document.onselectstart = function () { return false; };
}
if (document.ondrag !== undefined && savedhandlers.ondrag == null) {
savedhandlers.ondrag = document.ondrag;
document.ondrag = function () { return false; };
}
setSelectionPos(selection.first, e);
selection.active = true;
// this is a bit silly, but we have to use a closure to be
// able to whack the same handler again
mouseUpHandler = function (e) { onMouseUp(e); };
$(document).one("mouseup", mouseUpHandler);
}
function onMouseUp(e) {
mouseUpHandler = null;
// revert drag stuff for old-school browsers
if (document.onselectstart !== undefined)
document.onselectstart = savedhandlers.onselectstart;
if (document.ondrag !== undefined)
document.ondrag = savedhandlers.ondrag;
// no more dragging
selection.active = false;
updateSelection(e);
if (selectionIsSane())
triggerSelectedEvent();
else {
// this counts as a clear
plot.getPlaceholder().trigger("plotunselected", [ ]);
plot.getPlaceholder().trigger("plotselecting", [ null ]);
}
return false;
}
function getSelection() {
if (!selectionIsSane())
return null;
var r = {}, c1 = selection.first, c2 = selection.second;
$.each(plot.getAxes(), function (name, axis) {
if (axis.used) {
var p1 = axis.c2p(c1[axis.direction]), p2 = axis.c2p(c2[axis.direction]);
r[name] = { from: Math.min(p1, p2), to: Math.max(p1, p2) };
}
});
return r;
}
function triggerSelectedEvent() {
var r = getSelection();
plot.getPlaceholder().trigger("plotselected", [ r ]);
// backwards-compat stuff, to be removed in future
if (r.xaxis && r.yaxis)
plot.getPlaceholder().trigger("selected", [ { x1: r.xaxis.from, y1: r.yaxis.from, x2: r.xaxis.to, y2: r.yaxis.to } ]);
}
function clamp(min, value, max) {
return value < min ? min: (value > max ? max: value);
}
function setSelectionPos(pos, e) {
var o = plot.getOptions();
var offset = plot.getPlaceholder().offset();
var plotOffset = plot.getPlotOffset();
pos.x = clamp(0, e.pageX - offset.left - plotOffset.left, plot.width());
pos.y = clamp(0, e.pageY - offset.top - plotOffset.top, plot.height());
if (o.selection.mode == "y")
pos.x = pos == selection.first ? 0 : plot.width();
if (o.selection.mode == "x")
pos.y = pos == selection.first ? 0 : plot.height();
}
function updateSelection(pos) {
if (pos.pageX == null)
return;
setSelectionPos(selection.second, pos);
if (selectionIsSane()) {
selection.show = true;
plot.triggerRedrawOverlay();
}
else
clearSelection(true);
}
function clearSelection(preventEvent) {
if (selection.show) {
selection.show = false;
plot.triggerRedrawOverlay();
if (!preventEvent)
plot.getPlaceholder().trigger("plotunselected", [ ]);
}
}
// function taken from markings support in Flot
function extractRange(ranges, coord) {
var axis, from, to, key, axes = plot.getAxes();
for (var k in axes) {
axis = axes[k];
if (axis.direction == coord) {
key = coord + axis.n + "axis";
if (!ranges[key] && axis.n == 1)
key = coord + "axis"; // support x1axis as xaxis
if (ranges[key]) {
from = ranges[key].from;
to = ranges[key].to;
break;
}
}
}
// backwards-compat stuff - to be removed in future
if (!ranges[key]) {
axis = coord == "x" ? plot.getXAxes()[0] : plot.getYAxes()[0];
from = ranges[coord + "1"];
to = ranges[coord + "2"];
}
// auto-reverse as an added bonus
if (from != null && to != null && from > to) {
var tmp = from;
from = to;
to = tmp;
}
return { from: from, to: to, axis: axis };
}
function setSelection(ranges, preventEvent) {
var axis, range, o = plot.getOptions();
if (o.selection.mode == "y") {
selection.first.x = 0;
selection.second.x = plot.width();
}
else {
range = extractRange(ranges, "x");
selection.first.x = range.axis.p2c(range.from);
selection.second.x = range.axis.p2c(range.to);
}
if (o.selection.mode == "x") {
selection.first.y = 0;
selection.second.y = plot.height();
}
else {
range = extractRange(ranges, "y");
selection.first.y = range.axis.p2c(range.from);
selection.second.y = range.axis.p2c(range.to);
}
selection.show = true;
plot.triggerRedrawOverlay();
if (!preventEvent && selectionIsSane())
triggerSelectedEvent();
}
function selectionIsSane() {
var minSize = 5;
return Math.abs(selection.second.x - selection.first.x) >= minSize &&
Math.abs(selection.second.y - selection.first.y) >= minSize;
}
plot.clearSelection = clearSelection;
plot.setSelection = setSelection;
plot.getSelection = getSelection;
plot.hooks.bindEvents.push(function(plot, eventHolder) {
var o = plot.getOptions();
if (o.selection.mode != null) {
eventHolder.mousemove(onMouseMove);
eventHolder.mousedown(onMouseDown);
}
});
plot.hooks.drawOverlay.push(function (plot, ctx) {
// draw selection
if (selection.show && selectionIsSane()) {
var plotOffset = plot.getPlotOffset();
var o = plot.getOptions();
ctx.save();
ctx.translate(plotOffset.left, plotOffset.top);
var c = $.color.parse(o.selection.color);
ctx.strokeStyle = c.scale('a', 0.8).toString();
ctx.lineWidth = 1;
ctx.lineJoin = "round";
ctx.fillStyle = c.scale('a', 0.4).toString();
var x = Math.min(selection.first.x, selection.second.x),
y = Math.min(selection.first.y, selection.second.y),
w = Math.abs(selection.second.x - selection.first.x),
h = Math.abs(selection.second.y - selection.first.y);
ctx.fillRect(x, y, w, h);
ctx.strokeRect(x, y, w, h);
ctx.restore();
}
});
plot.hooks.shutdown.push(function (plot, eventHolder) {
eventHolder.unbind("mousemove", onMouseMove);
eventHolder.unbind("mousedown", onMouseDown);
if (mouseUpHandler)
$(document).unbind("mouseup", mouseUpHandler);
});
}
$.plot.plugins.push({
init: init,
options: {
selection: {
mode: null, // one of null, "x", "y" or "xy"
color: "#e8cfac"
}
},
name: 'selection',
version: '1.1'
});
})(jQuery);

292
pkgs/plt-services/meta/drdr/static/render.css
View File

@ -1,292 +0,0 @@
html {
overflow-y: scroll;
}
a img {
border: 0;
}
body {
color: black;
background-color: white;
font-family: Optima, Arial, Verdana, Helvetica, sans-serif;
margin: 0px;
padding: 0px;
}
.content {
margin-left: auto;
margin-right: auto;
width: 50em;
}
#footer {
text-align: right;
width: 50em;
background: #F5F5DC;
margin-top: 2em;
}
.help h1 {
background: #F5F5DC;
font-size: 130%;
width: 100%;
}
.stderr {
color: red;
}
.stdout {
color: black;
}
.difference,.unprintable {
background: #00ffc8;
}
.breadcrumb {
padding-left: 1em;
padding-right: 1em;
background: #FFCC66;
font-size: 120%;
font-weight: bold;
}
.breadcrumb a.parent {
color: black;
text-decoration: none;
font-weight: normal;
}
.breadcrumb a.parent:hover {
color: blue;
text-decoration: underline;
}
div.error {
margin-top: 1em;
background-color: rgba(100%,0%,0%,0.5);
border: 1px solid black;
padding: 1em;
}
span.revnav {
margin-left: 1em;
margin-right: 1em;
padding-left: 1em;
padding-right: 1em;
background: #FFCC66;
font-size: 120%;
font-weight: bold;
}
span.revnav a {
margin-right: 5px;
color: black;
text-decoration: none;
font-weight: normal;
}
span.revnav a:hover {
color: blue;
text-decoration: underline;
}
span.filepath {
font-family: monospace;
}
table.data {
margin-top: 1em;
width: 100%;
background-color: rgb(90%,90%,90%);
border: 1px solid black;
padding: 1em;
}
table.data > tbody > tr > td:nth-child(1) > a {
color: black;
text-decoration: none;
}
table.data > tbody > tr > td:nth-child(1) > a:hover {
color: blue;
text-decoration: underline;
}
table.data > tbody > tr > td:nth-child(1) {
font-weight: bold;
width: 15%;
text-align: right;
vertical-align: top;
padding-right: 1em;
}
pre {
overflow-x: auto; /* Use horizontal scroller if needed; for Firefox 2, not needed in Firefox 3 */
white-space: pre-wrap; /* css-3 */
white-space: -moz-pre-wrap !important; /* Mozilla, since 1999 */
white-space: -pre-wrap; /* Opera 4-6 */
white-space: -o-pre-wrap; /* Opera 7 */
/* width: 99%; */
word-wrap: break-word; /* Internet Explorer 5.5+ */
}
div.status {
margin-top: 1em;
background-color: rgb(90%,90%,90%);
border: 1px solid black;
padding: 1em;
}
div.status ul {
list-style-type: none;
}
div.status a {
color: black;
text-decoration: none;
font-weight: normal;
}
div.status a:hover {
color: blue;
text-decoration: underline;
}
.status .tag {
float: right;
color: rgb(50%,50%,50%);
font-size: 200%;
margin-top: -0.5em;
padding-top: 0px;
}
.commandline {
font-family: monospace;
white-space: pre-wrap;
}
.commandline:before { content: "'"; }
.commandline:after { content: "'"; }
tr.changes table tr td:nth-child(1) {
text-align: left;
padding-right: 0.5em;
}
table.dirlist {
margin-top: 1em;
background-color: #F5F5DC;
width: 100%;
}
p.output {
font-family: monospace;
}
div.output {
margin-top: 1em;
background-color: #F5F5DC;
font-family: monospace;
width: 100%;
padding: 0.5em;
border: 1px solid black;
}
div.output p {
margin: 0.5em;
}
.dirlist thead tr td:nth-child(n+2) {
text-align: center;
}
.dirlist tbody tr td:nth-child(2) {
text-align: right;
}
.dirlist tbody tr td:nth-child(3) {
text-align: right;
}
.dirlist tbody tr td:nth-child(n+4) {
text-align: center;
}
.dirlist tfoot tr td:nth-child(2) {
text-align: right;
}
.dirlist tfoot tr td:nth-child(3) {
text-align: right;
}
.dirlist tfoot tr td:nth-child(n+4) {
text-align: center;
}
.dirlist tbody tr td.building {
text-align: center;
}
.dirlist tbody tr td.author {
text-align: center;
}
.dir, .file {
cursor: pointer;
font-family: Courier New, Courier, monospace;
}
.dir {
margin: 3px;
padding: 3px;
margin-left: 3em;
background: rgb(90%,90%,90%);
}
.dir a {
text-decoration: none;
color: black;
font-weight: bold;
}
.dir:hover {
margin: 3px;
padding: 3px;
margin-left: 3em;
background: rgb(100%,100%,80%);
/* border: 1px black solid; */
}
.branch-refs-heads-release {
background: rgb(90%,70%,90%);
}
.branch-refs-heads-release:hover {
background: rgb(100%,80%,100%);
}
.file {
margin: 3px;
padding: 3px;
margin-left: 3em;
background: rgb(95%,95%,95%);
}
.file a {
text-decoration: none;
color: black;
}
.file:hover {
margin: 3px;
padding: 3px;
margin-left: 3em;
background: rgb(100%,100%,90%);
}
div.timing img {
border: 0px;
width: 100%;
}
div.timing {
margin-top: 2em;
width: 50em;
}
table.diff tr.difference td {
width: 48%;
}

3
pkgs/plt-services/meta/drdr/static/robots.txt
View File

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

502
pkgs/plt-services/meta/drdr/static/sorttable.js
View File

@ -1,502 +0,0 @@
function TocviewToggle(glyphid, id) {
var glyph = document.getElementById(glyphid);
var s = document.getElementById(id).style;
var expand = s.display == "none";
s.display = expand ? "block" : "none";
glyph.innerHTML = expand ? "&#9660;" : "&#9658;";
}
/*
SortTable
version 2
7th April 2007
Stuart Langridge, http://www.kryogenix.org/code/browser/sorttable/
Instructions:
Download this file
Add <script src="sorttable.js"></script> to your HTML
Add class="sortable" to any table you'd like to make sortable
Click on the headers to sort
Thanks to many, many people for contributions and suggestions.
Licenced as X11: http://www.kryogenix.org/code/browser/licence.html
This basically means: do what you want with it.
*/
var stIsIE = /*@cc_on!@*/false;
sorttable = {
init: function() {
// quit if this function has already been called
if (arguments.callee.done) return;
// flag this function so we don't do the same thing twice
arguments.callee.done = true;
// kill the timer
if (_timer) clearInterval(_timer);
if (!document.createElement || !document.getElementsByTagName) return;
sorttable.DATE_RE = /^(\d\d?)[\/\.-](\d\d?)[\/\.-]((\d\d)?\d\d)$/;
forEach(document.getElementsByTagName('table'), function(table) {
if (table.className.search(/\bsortable\b/) != -1) {
sorttable.makeSortable(table);
}
});
},
makeSortable: function(table) {
if (table.getElementsByTagName('thead').length == 0) {
// table doesn't have a tHead. Since it should have, create one and
// put the first table row in it.
the = document.createElement('thead');
the.appendChild(table.rows[0]);
table.insertBefore(the,table.firstChild);
}
// Safari doesn't support table.tHead, sigh
if (table.tHead == null) table.tHead = table.getElementsByTagName('thead')[0];
if (table.tHead.rows.length != 1) return; // can't cope with two header rows
// Sorttable v1 put rows with a class of "sortbottom" at the bottom (as
// "total" rows, for example). This is B&R, since what you're supposed
// to do is put them in a tfoot. So, if there are sortbottom rows,
// for backwards compatibility, move them to tfoot (creating it if needed).
sortbottomrows = [];
for (var i=0; i<table.rows.length; i++) {
if (table.rows[i].className.search(/\bsortbottom\b/) != -1) {
sortbottomrows[sortbottomrows.length] = table.rows[i];
}
}
if (sortbottomrows) {
if (table.tFoot == null) {
// table doesn't have a tfoot. Create one.
tfo = document.createElement('tfoot');
table.appendChild(tfo);
}
for (var i=0; i<sortbottomrows.length; i++) {
tfo.appendChild(sortbottomrows[i]);
}
delete sortbottomrows;
}
// work through each column and calculate its type
headrow = table.tHead.rows[0].cells;
for (var i=0; i<headrow.length; i++) {
// manually override the type with a sorttable_type attribute
if (!headrow[i].className.match(/\bsorttable_nosort\b/)) { // skip this col
mtch = headrow[i].className.match(/\bsorttable_([a-z0-9]+)\b/);
if (mtch) { override = mtch[1]; }
if (mtch && typeof sorttable["sort_"+override] == 'function') {
headrow[i].sorttable_sortfunction = sorttable["sort_"+override];
} else {
headrow[i].sorttable_sortfunction = sorttable.guessType(table,i);
}
// make it clickable to sort
headrow[i].sorttable_columnindex = i;
headrow[i].sorttable_tbody = table.tBodies[0];
dean_addEvent(headrow[i],"click", function(e) {
if (this.className.search(/\bsorttable_sorted\b/) != -1) {
// if we're already sorted by this column, just
// reverse the table, which is quicker
sorttable.reverse(this.sorttable_tbody);
this.className = this.className.replace('sorttable_sorted',
'sorttable_sorted_reverse');
this.removeChild(document.getElementById('sorttable_sortfwdind'));
sortrevind = document.createElement('span');
sortrevind.id = "sorttable_sortrevind";
sortrevind.innerHTML = stIsIE ? '&nbsp<font face="webdings">5</font>' : '&nbsp;&#x25B4;';
this.appendChild(sortrevind);
return;
}
if (this.className.search(/\bsorttable_sorted_reverse\b/) != -1) {
// if we're already sorted by this column in reverse, just
// re-reverse the table, which is quicker
sorttable.reverse(this.sorttable_tbody);
this.className = this.className.replace('sorttable_sorted_reverse',
'sorttable_sorted');
this.removeChild(document.getElementById('sorttable_sortrevind'));
sortfwdind = document.createElement('span');
sortfwdind.id = "sorttable_sortfwdind";
sortfwdind.innerHTML = stIsIE ? '&nbsp<font face="webdings">6</font>' : '&nbsp;&#x25BE;';
this.appendChild(sortfwdind);
return;
}
// remove sorttable_sorted classes
theadrow = this.parentNode;
forEach(theadrow.childNodes, function(cell) {
if (cell.nodeType == 1) { // an element
cell.className = cell.className.replace('sorttable_sorted_reverse','');
cell.className = cell.className.replace('sorttable_sorted','');
}
});
sortfwdind = document.getElementById('sorttable_sortfwdind');
if (sortfwdind) { sortfwdind.parentNode.removeChild(sortfwdind); }
sortrevind = document.getElementById('sorttable_sortrevind');
if (sortrevind) { sortrevind.parentNode.removeChild(sortrevind); }
this.className += ' sorttable_sorted';
sortfwdind = document.createElement('span');
sortfwdind.id = "sorttable_sortfwdind";
sortfwdind.innerHTML = stIsIE ? '&nbsp<font face="webdings">6</font>' : '&nbsp;&#x25BE;';
this.appendChild(sortfwdind);
// build an array to sort. This is a Schwartzian transform thing,
// i.e., we "decorate" each row with the actual sort key,
// sort based on the sort keys, and then put the rows back in order
// which is a lot faster because you only do getInnerText once per row
row_array = [];
col = this.sorttable_columnindex;
rows = this.sorttable_tbody.rows;
for (var j=0; j<rows.length; j++) {
row_array[row_array.length] = [sorttable.getInnerText(rows[j].cells[col]), rows[j]];
}
/* If you want a stable sort, uncomment the following line */
//sorttable.shaker_sort(row_array, this.sorttable_sortfunction);
/* and comment out this one */
row_array.sort(this.sorttable_sortfunction);
row_array.reverse();
tb = this.sorttable_tbody;
for (var j=0; j<row_array.length; j++) {
tb.appendChild(row_array[j][1]);
}
delete row_array;
});
}
}
},
guessType: function(table, column) {
// guess the type of a column based on its first non-blank row
sortfn = sorttable.sort_alpha;
for (var i=0; i<table.tBodies[0].rows.length; i++) {
text = sorttable.getInnerText(table.tBodies[0].rows[i].cells[column]);
if (text != '') {
if (text.match(/^-?[£$¤]?[\d,.]+%?$/)) {
return sorttable.sort_numeric;
}
// check for a date: dd/mm/yyyy or dd/mm/yy
// can have / or . or - as separator
// can be mm/dd as well
possdate = text.match(sorttable.DATE_RE)
if (possdate) {
// looks like a date
first = parseInt(possdate[1]);
second = parseInt(possdate[2]);
if (first > 12) {
// definitely dd/mm
return sorttable.sort_ddmm;
} else if (second > 12) {
return sorttable.sort_mmdd;
} else {
// looks like a date, but we can't tell which, so assume
// that it's dd/mm (English imperialism!) and keep looking
sortfn = sorttable.sort_ddmm;
}
}
}
}
return sortfn;
},
getInnerText: function(node) {
// gets the text we want to use for sorting for a cell.
// strips leading and trailing whitespace.
// this is *not* a generic getInnerText function; it's special to sorttable.
// for example, you can override the cell text with a customkey attribute.
// it also gets .value for <input> fields.
hasInputs = (typeof node.getElementsByTagName == 'function') &&
node.getElementsByTagName('input').length;
if (node.getAttribute("sorttable_customkey") != null) {
return node.getAttribute("sorttable_customkey");
}
else if (typeof node.textContent != 'undefined' && !hasInputs) {
return node.textContent.replace(/^\s+|\s+$/g, '');
}
else if (typeof node.innerText != 'undefined' && !hasInputs) {
return node.innerText.replace(/^\s+|\s+$/g, '');
}
else if (typeof node.text != 'undefined' && !hasInputs) {
return node.text.replace(/^\s+|\s+$/g, '');
}
else {
switch (node.nodeType) {
case 3:
if (node.nodeName.toLowerCase() == 'input') {
return node.value.replace(/^\s+|\s+$/g, '');
}
case 4:
return node.nodeValue.replace(/^\s+|\s+$/g, '');
break;
case 1:
case 11:
var innerText = '';
for (var i = 0; i < node.childNodes.length; i++) {
innerText += sorttable.getInnerText(node.childNodes[i]);
}
return innerText.replace(/^\s+|\s+$/g, '');
break;
default:
return '';
}
}
},
reverse: function(tbody) {
// reverse the rows in a tbody
newrows = [];
for (var i=0; i<tbody.rows.length; i++) {
newrows[newrows.length] = tbody.rows[i];
}
for (var i=newrows.length-1; i>=0; i--) {
tbody.appendChild(newrows[i]);
}
delete newrows;
},
/* sort functions
each sort function takes two parameters, a and b
you are comparing a[0] and b[0] */
sort_numeric: function(a,b) {
aa = parseFloat(a[0].replace(/[^0-9.-]/g,''));
if (isNaN(aa)) aa = 0;
bb = parseFloat(b[0].replace(/[^0-9.-]/g,''));
if (isNaN(bb)) bb = 0;
return aa-bb;
},
sort_alpha: function(a,b) {
if (a[0]==b[0]) return 0;
if (a[0]<b[0]) return -1;
return 1;
},
sort_ddmm: function(a,b) {
mtch = a[0].match(sorttable.DATE_RE);
y = mtch[3]; m = mtch[2]; d = mtch[1];
if (m.length == 1) m = '0'+m;
if (d.length == 1) d = '0'+d;
dt1 = y+m+d;
mtch = b[0].match(sorttable.DATE_RE);
y = mtch[3]; m = mtch[2]; d = mtch[1];
if (m.length == 1) m = '0'+m;
if (d.length == 1) d = '0'+d;
dt2 = y+m+d;
if (dt1==dt2) return 0;
if (dt1<dt2) return -1;
return 1;
},
sort_mmdd: function(a,b) {
mtch = a[0].match(sorttable.DATE_RE);
y = mtch[3]; d = mtch[2]; m = mtch[1];
if (m.length == 1) m = '0'+m;
if (d.length == 1) d = '0'+d;
dt1 = y+m+d;
mtch = b[0].match(sorttable.DATE_RE);
y = mtch[3]; d = mtch[2]; m = mtch[1];
if (m.length == 1) m = '0'+m;
if (d.length == 1) d = '0'+d;
dt2 = y+m+d;
if (dt1==dt2) return 0;
if (dt1<dt2) return -1;
return 1;
},
shaker_sort: function(list, comp_func) {
// A stable sort function to allow multi-level sorting of data
// see: http://en.wikipedia.org/wiki/Cocktail_sort
// thanks to Joseph Nahmias
var b = 0;
var t = list.length - 1;
var swap = true;
while(swap) {
swap = false;
for(var i = b; i < t; ++i) {
if ( comp_func(list[i], list[i+1]) > 0 ) {
var q = list[i]; list[i] = list[i+1]; list[i+1] = q;
swap = true;
}
} // for
t--;
if (!swap) break;
for(var i = t; i > b; --i) {
if ( comp_func(list[i], list[i-1]) < 0 ) {
var q = list[i]; list[i] = list[i-1]; list[i-1] = q;
swap = true;
}
} // for
b++;
} // while(swap)
}
}
/* ******************************************************************
Supporting functions: bundled here to avoid depending on a library
****************************************************************** */
// Dean Edwards/Matthias Miller/John Resig
/* for Mozilla/Opera9 */
if (document.addEventListener) {
document.addEventListener("DOMContentLoaded", sorttable.init, false);
}
/* for Internet Explorer */
/*@cc_on @*/
/*@if (@_win32)
document.write("<script id=__ie_onload defer src=javascript:void(0)><\/script>");
var script = document.getElementById("__ie_onload");
script.onreadystatechange = function() {
if (this.readyState == "complete") {
sorttable.init(); // call the onload handler
}
};
/*@end @*/
/* for Safari */
if (/WebKit/i.test(navigator.userAgent)) { // sniff
var _timer = setInterval(function() {
if (/loaded|complete/.test(document.readyState)) {
sorttable.init(); // call the onload handler
}
}, 10);
}
/* for other browsers */
window.onload = sorttable.init;
// written by Dean Edwards, 2005
// with input from Tino Zijdel, Matthias Miller, Diego Perini
// http://dean.edwards.name/weblog/2005/10/add-event/
function dean_addEvent(element, type, handler) {
if (element.addEventListener) {
element.addEventListener(type, handler, false);
} else {
// assign each event handler a unique ID
if (!handler.$$guid) handler.$$guid = dean_addEvent.guid++;
// create a hash table of event types for the element
if (!element.events) element.events = {};
// create a hash table of event handlers for each element/event pair
var handlers = element.events[type];
if (!handlers) {
handlers = element.events[type] = {};
// store the existing event handler (if there is one)
if (element["on" + type]) {
handlers[0] = element["on" + type];
}
}
// store the event handler in the hash table
handlers[handler.$$guid] = handler;
// assign a global event handler to do all the work
element["on" + type] = handleEvent;
}
};
// a counter used to create unique IDs
dean_addEvent.guid = 1;
function removeEvent(element, type, handler) {
if (element.removeEventListener) {
element.removeEventListener(type, handler, false);
} else {
// delete the event handler from the hash table
if (element.events && element.events[type]) {
delete element.events[type][handler.$$guid];
}
}
};
function handleEvent(event) {
var returnValue = true;
// grab the event object (IE uses a global event object)
event = event || fixEvent(((this.ownerDocument || this.document || this).parentWindow || window).event);
// get a reference to the hash table of event handlers
var handlers = this.events[event.type];
// execute each event handler
for (var i in handlers) {
this.$$handleEvent = handlers[i];
if (this.$$handleEvent(event) === false) {
returnValue = false;
}
}
return returnValue;
};
function fixEvent(event) {
// add W3C standard event methods
event.preventDefault = fixEvent.preventDefault;
event.stopPropagation = fixEvent.stopPropagation;
return event;
};
fixEvent.preventDefault = function() {
this.returnValue = false;
};
fixEvent.stopPropagation = function() {
this.cancelBubble = true;
}
// Dean's forEach: http://dean.edwards.name/base/forEach.js
/*
forEach, version 1.0
Copyright 2006, Dean Edwards
License: http://www.opensource.org/licenses/mit-license.php
*/
// array-like enumeration
if (!Array.forEach) { // mozilla already supports this
Array.forEach = function(array, block, context) {
for (var i = 0; i < array.length; i++) {
block.call(context, array[i], i, array);
}
};
}
// generic enumeration
Function.prototype.forEach = function(object, block, context) {
for (var key in object) {
if (typeof this.prototype[key] == "undefined") {
block.call(context, object[key], key, object);
}
}
};
// character enumeration
String.forEach = function(string, block, context) {
Array.forEach(string.split(""), function(chr, index) {
block.call(context, chr, index, string);
});
};
// globally resolve forEach enumeration
var forEach = function(object, block, context) {
if (object) {
var resolve = Object; // default
if (object instanceof Function) {
// functions have a "length" property
resolve = Function;
} else if (object.forEach instanceof Function) {
// the object implements a custom forEach method so use that
object.forEach(block, context);
return;
} else if (typeof object == "string") {
// the object is a string
resolve = String;
} else if (typeof object.length == "number") {
// the object is array-like
resolve = Array;
}
resolve.forEach(object, block, context);
}
};

49
pkgs/plt-services/meta/drdr/status-analyze.rkt
View File

@ -1,49 +0,0 @@
#lang racket/base
(require racket/list
racket/match
racket/contract/base
"status.rkt")
(define (log-divide l)
(match l
[(list)
(list empty)]
[(cons s l)
(define rl (log-divide l))
(match-define (cons trl rrl) rl)
(match s
[(? stdout?)
(match trl
[(or (list) (cons (? stdout?) _))
(cons (cons s trl) rrl)]
[_
(cons (list s) rl)])]
[(? stderr?)
(cons (cons s trl) rrl)])]))
'
(module+ test
(require rackunit)
(check-equal?
(log-divide empty)
(list empty))
(check-equal?
(log-divide (list (stdout #"1")))
(list (list (stdout #"1"))))
(check-equal?
(log-divide (list (stdout #"1") (stdout #"2")))
(list (list (stdout #"1") (stdout #"2"))))
(check-equal?
(log-divide (list (stdout #"1") (stderr #"A") (stdout #"2")))
(list (list (stdout #"1"))
(list (stderr #"A") (stdout #"2"))))
(check-equal?
(log-divide (list (stdout #"1") (stderr #"A") (stderr #"B") (stdout #"2")))
(list (list (stdout #"1"))
(list (stderr #"A") (stderr #"B") (stdout #"2")))))
(provide
(contract-out
[log-divide
(-> (listof event?)
(listof (listof event?)))]))

38
pkgs/plt-services/meta/drdr/status.rkt
View File

@ -1,38 +0,0 @@
#lang racket/base
(require racket/contract/base)
(define-struct event () #:prefab)
(define-struct (stdout event) (bytes) #:prefab)
(define-struct (stderr event) (bytes) #:prefab)
(define-struct status (start end command-line output-log) #:prefab)
(define-struct (timeout status) () #:prefab)
(define-struct (exit status) (code) #:prefab)
(define (status-duration s)
(- (status-end s) (status-start s)))
(provide/contract
;; Notice the event? is basically (or/c stdout? stderr?) because
;; event is not exposed, so the only event?s that can exist are these
;; two.
[event?
(-> any/c boolean?)]
[struct (stdout event) ([bytes bytes?])]
[struct (stderr event) ([bytes bytes?])]
[struct status ([start number?]
[end number?]
[command-line (listof string?)]
[output-log (listof event?)])]
[struct (exit status)
([start number?]
[end number?]
[command-line (listof string?)]
[output-log (listof event?)]
[code exact-integer?])]
[struct (timeout status)
([start number?]
[end number?]
[command-line (listof string?)]
[output-log (listof event?)])]
[status-duration (status? . -> . number?)])

19
pkgs/plt-services/meta/drdr/svn.rkt
View File

@ -1,19 +0,0 @@
#lang racket
(define-struct svn-rev () #:prefab)
(define-struct (svn-rev-nolog svn-rev) () #:prefab)
(define-struct (svn-rev-log svn-rev) (num author date msg changes) #:prefab)
(define-struct svn-change (action path) #:prefab)
(provide/contract
[struct svn-rev ()]
[struct (svn-rev-nolog svn-rev) ()]
[struct (svn-rev-log svn-rev)
([num exact-nonnegative-integer?]
[author string?]
[date string?]
[msg string?]
[changes (listof svn-change?)])]
[struct svn-change
([action symbol?]
[path path-string?])])

11
pkgs/plt-services/meta/drdr/tests/loud.rkt
View File

@ -1,11 +0,0 @@
#lang racket
(define n (command-line #:args (n) (string->number n)))
(for ([i (in-range n)])
(fprintf (if (even? i)
(current-error-port)
(current-output-port))
"~a\n"
i))

32
pkgs/plt-services/meta/drdr/tests/run-collect.rkt
View File

@ -1,32 +0,0 @@
#lang racket
(require "../run-collect.rkt"
"../status.rkt"
racket/runtime-path
tests/eli-tester)
(define-runtime-path loud-file "loud.rkt")
(define (run-loud n)
(run/collect/wait #:env (hash)
#:timeout (* 10)
(path->string (find-system-path 'exec-file))
(list "-t" (path->string loud-file)
"--" (number->string n))))
(define (test-run-loud n)
(test
#:failure-prefix (number->string n)
(status-output-log (run-loud n))
=>
(for/list ([i (in-range n)])
((if (even? i)
make-stderr
make-stdout)
(string->bytes/utf-8
(number->string i))))))
(test
(for ([n (in-range 10)])
(test-run-loud n)))
(run-loud 10)

18
pkgs/plt-services/meta/drdr/time-check.rkt
View File

@ -1,18 +0,0 @@
#lang racket/base
(define (check f)
(with-handlers ([exn:fail? (λ (x) x)])
(with-input-from-file f
(λ ()
(for ([e (in-port)])
(void))))
#f))
(for ([f (in-directory)]
#:when (file-exists? f)
#:when (regexp-match #rx"timing$" f))
(define c (check f))
(printf "~a\n" f)
(when c
(printf "\t~a\n" c)
(exit 1)))

56
pkgs/plt-services/meta/drdr/time-file.rkt
View File

@ -1,56 +0,0 @@
#lang racket
(require "config.rkt"
"dirstruct.rkt"
"cache.rkt"
"path-utils.rkt"
"status.rkt")
(define revision #f)
(define filename
(command-line #:program "time-file"
#:once-any
["-H" "Run on all revisions"
(set! revision #f)]
["-r" rev "Run on one revision"
(set! revision (string->number rev))]
#:args (filename) filename))
(define (output-for-rev rev)
(define log
(read-cache* (build-path (revision-log-dir rev) filename)))
(when log
(printf "~S\n"
(list rev
(status-duration log)
(filter-map
(match-lambda
[(struct stdout ((regexp #px#"cpu time: (\\d+) real time: (\\d+) gc time: (\\d+)"
(list _
(app (compose string->number bytes->string/utf-8) cpu)
(app (compose string->number bytes->string/utf-8) real)
(app (compose string->number bytes->string/utf-8) gc)))))
(list cpu real gc)]
[_
#f])
(status-output-log log))))))
(define data-file (path-timing-log filename))
(with-handlers ([exn:fail? void])
(make-parent-directory data-file))
(printf "Making log for ~a\n" filename)
(if revision
(with-output-to-file
data-file
#:exists 'append
(lambda ()
(output-for-rev revision)))
(with-output-to-file
data-file
#:exists 'replace
(lambda ()
(init-revisions!)
(for ([rev (in-list revisions)])
(output-for-rev rev)))))

66
pkgs/plt-services/meta/drdr/time.rkt
View File

@ -1,66 +0,0 @@
#lang racket
(require (planet jaymccarthy/job-queue)
racket/system
"config.rkt"
"notify.rkt"
"dirstruct.rkt"
"sema.rkt"
"cache.rkt")
(define test-workers (make-job-queue (number-of-cpus)))
(define start-revision #f)
(define history? #f)
(command-line #:program "time"
#:once-each
["-H" "Run on all revisions"
(set! history? #t)]
["-r" rev
"Start with a particular revision"
(set! start-revision (string->number rev))])
(unless start-revision
(init-revisions!)
(set! start-revision (newest-revision)))
(define count-sema (make-semaphore 0))
(define (make-log! filename)
(submit-job!
test-workers
(lambda ()
(notify! "Dropping timing for ~a" filename)
(apply
system*/exit-code
(path->string
(build-path (plt-directory) "plt" "bin" "racket"))
"-t"
(path->string (build-path (drdr-directory) "time-file.rkt"))
"--"
(append
(if history?
(list "-H")
(list "-r" (number->string start-revision)))
(list
(path->string filename))))
(notify! "Done with ~a" filename)
(semaphore-post count-sema))))
(define (find-files p l)
(for/fold ([i 0])
([f (in-list (cached-directory-list* p))])
(define fp (build-path p f))
(define fl (list* f l))
(if (cached-directory-exists? fp)
(+ i (find-files fp fl))
(begin (make-log! (apply build-path (reverse fl)))
(add1 i)))))
(define how-many-files
(find-files (revision-log-dir start-revision)
empty))
(semaphore-wait* count-sema how-many-files)
(stop-job-queue! test-workers)

39
pkgs/plt-services/meta/drdr/vdbm.rkt
View File

@ -1,39 +0,0 @@
#lang racket
(require (planet jaymccarthy/dbm)
"wrap-dict.rkt")
(define (read-string s)
(with-input-from-string s read))
(define (write-string v)
(with-output-to-string (lambda () (write v))))
(define make-read/write-dict
(make-wrapped-dict
write-string read-string
write-string read-string))
(define (call-with-vdbm pth f)
(define a-dbm #f)
(dynamic-wind
(lambda ()
(set! a-dbm (dbm-open pth)))
(lambda ()
(f (make-read/write-dict a-dbm)))
(lambda ()
(dbm-close! a-dbm))))
(provide/contract
[call-with-vdbm (path-string? (dict? . -> . any) . -> . any)])
;; Test
(call-with-vdbm
"test"
(lambda (a-dict)
(list
(dict-set! a-dict (cons 1 2) 50)
(dict-ref a-dict (cons 1 2))
(for/list ([k (in-dict-keys a-dict)])
k))))

89
pkgs/plt-services/meta/drdr/xorg.conf
View File

@ -1,89 +0,0 @@
Section "ServerFlags"
option "AllowMouseOpenFail"
EndSection
Section "ServerLayout"
Identifier "X.org Configured"
Screen 0 "Screen0" 0 0
InputDevice "Mouse0" "CorePointer"
InputDevice "Keyboard0" "CoreKeyboard"
EndSection
Section "Files"
ModulePath "/usr/lib/xorg/modules"
FontPath "/usr/share/fonts/X11/misc"
FontPath "/usr/share/fonts/X11/cyrillic"
FontPath "/usr/share/fonts/X11/100dpi/:unscaled"
FontPath "/usr/share/fonts/X11/75dpi/:unscaled"
FontPath "/usr/share/fonts/X11/Type1"
FontPath "/usr/share/fonts/X11/100dpi"
FontPath "/usr/share/fonts/X11/75dpi"
FontPath "/var/lib/defoma/x-ttcidfont-conf.d/dirs/TrueType"
FontPath "built-ins"
EndSection
Section "Module"
Load "dbe"
Load "dri"
Load "glx"
Load "record"
Load "extmod"
Load "dri2"
EndSection
Section "InputDevice"
Identifier "Keyboard0"
Driver "void"
EndSection
Section "InputDevice"
Identifier "Mouse0"
Driver "void"
EndSection
Section "Monitor"
Identifier "Monitor0"
VendorName "AVO"
ModelName "Smart Cable"
HorizSync 24.0 - 61.0
VertRefresh 56.0 - 75.0
EndSection
Section "Device"
Identifier "Card0"
Driver "mga"
VendorName "Matrox Graphics, Inc."
BoardName "MGA G200e [Pilot] ServerEngines (SEP1)"
BusID "PCI:30:0:0"
EndSection
Section "Screen"
Identifier "Screen0"
Device "Card0"
Monitor "Monitor0"
SubSectionSub "Display"
Viewport 0 0
Depth 1
EndSubSection
SubSectionSub "Display"
Viewport 0 0
Depth 4
EndSubSection
SubSectionSub "Display"
Viewport 0 0
Depth 8
EndSubSection
SubSectionSub "Display"
Viewport 0 0
Depth 15
EndSubSection
SubSectionSub "Display"
Viewport 0 0
Depth 16
EndSubSection
SubSectionSub "Display"
Viewport 0 0
Depth 24
EndSubSection
EndSection