From a11734d990833bd25632ee999924be61550f6859 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 8 Aug 2011 10:07:51 -0600 Subject: [PATCH] Getting it working after the crash --- collects/meta/drdr/INSTALL | 47 ++ collects/meta/drdr/analyze.rkt | 39 +- collects/meta/drdr/copy.sh | 2 +- collects/meta/drdr/main.rkt | 8 +- collects/meta/drdr/plt-build.rkt | 214 +++--- collects/meta/drdr/render.rkt | 1044 +++++++++++++------------- collects/meta/drdr/static/robots.txt | 3 + 7 files changed, 739 insertions(+), 618 deletions(-) create mode 100644 collects/meta/drdr/INSTALL create mode 100644 collects/meta/drdr/static/robots.txt diff --git a/collects/meta/drdr/INSTALL b/collects/meta/drdr/INSTALL new file mode 100644 index 0000000000..1d42e16eee --- /dev/null +++ b/collects/meta/drdr/INSTALL @@ -0,0 +1,47 @@ +0. Copy source to /opt/plt/drdr + +1. Create + +/opt/plt +/opt/plt/plt (Racket install) +/opt/plt/builds +/opt/plt/future-builds +/opt/plt/logs +/opt/plt/builds/ (for the first build) + +2. Install stuff + +sudo apt-get install xorg fluxbox python-software-properties gcc libcairo2 libpango1.0-0 libgtk2.0-0 texlive lib32gmp3 libreadline5 libpcre3-dev libgmp3-dev +sudo add-apt-repository ppa:git-core/ppa +sudo apt-get update +sudo apt-get install git-core + +3. Setup git + +cd /opt/plt +git clone http://git.racket-lang.org/plt.git repo + +4. Setup firewall + +sudo ufw allow 22 +sudo ufw enable + +sudo vim /etc/ufw/before.rules + +*nat +:PREROUTING ACCEPT [0:0] +-A PREROUTING -p tcp --dport 80 -j REDIRECT --to-port 9000 +COMMIT + +sudo ufw allow 80 +sudo ufw allow 9000 +sudo service ufw restart + +5. + +setuid on /usr/bin/Xorg + +6. + +sudo apt-get install postfix +# Use the Internet site setup diff --git a/collects/meta/drdr/analyze.rkt b/collects/meta/drdr/analyze.rkt index 2d1d8468a2..ac95efd885 100644 --- a/collects/meta/drdr/analyze.rkt +++ b/collects/meta/drdr/analyze.rkt @@ -61,11 +61,14 @@ (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)))) + (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)) @@ -118,10 +121,19 @@ (map lc->number (list timeout unclean stderr changes))) (define totals - (apply format "(timeout ~a) (unclean ~a) (stderr ~a) (changes ~a)" (map number->string nums))) + (apply + format + "(timeout ~a) (unclean ~a) (stderr ~a) (changes ~a)" + (map number->string nums))) (define (path->url pth) (format "http://drdr.racket-lang.org/~a~a" cur-rev pth)) - (define responsible-ht (statuses->responsible-ht cur-rev timeout unclean stderr changes)) + (define responsible-ht + (statuses->responsible-ht + cur-rev + timeout + unclean + stderr + changes)) (define responsibles (for/list ([(responsible ht) (in-hash responsible-ht)] #:when (ormap (curry hash-has-key? ht) @@ -142,14 +154,15 @@ ; There is a condition (not (empty? responsibles)) ; It is different from before - diff + (hash? diff) (for*/or ([(r ht) (in-hash diff)] [(id ps) (in-hash ht)]) - (and (for/or ([p (in-list ps)]) - ; 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)))))) + (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 (append (if include-committer? (list committer) diff --git a/collects/meta/drdr/copy.sh b/collects/meta/drdr/copy.sh index c529dc4e92..48589b8479 100755 --- a/collects/meta/drdr/copy.sh +++ b/collects/meta/drdr/copy.sh @@ -1,3 +1,3 @@ #!/bin/sh -rsync -avz . drdr:/opt/svn/drdr/ --exclude=compiled --delete --exclude=data +rsync -avz . ${1}drdr:/opt/svn/drdr/ --exclude=compiled --delete --exclude=data diff --git a/collects/meta/drdr/main.rkt b/collects/meta/drdr/main.rkt index dc62bb8635..1c3fba0eb6 100644 --- a/collects/meta/drdr/main.rkt +++ b/collects/meta/drdr/main.rkt @@ -49,7 +49,8 @@ (path->string (build-path (plt-directory) "plt" "bin" "racket")) "-t" - (path->string (build-path (drdr-directory) "make-archive.rkt")) + (path->string + (build-path (drdr-directory) "make-archive.rkt")) "--" "--many" (number->string 100)))))) @@ -60,8 +61,9 @@ cur-rev (lambda (newer) (for ([rev (in-list newer)]) - (write-cache! (future-record-path rev) - (get-scm-commit-msg rev (plt-repository))))) + (write-cache! + (future-record-path rev) + (get-scm-commit-msg rev (plt-repository))))) (lambda (prev-rev cur-rev) (handle-revision prev-rev cur-rev) diff --git a/collects/meta/drdr/plt-build.rkt b/collects/meta/drdr/plt-build.rkt index 97fff475c6..b96a042a45 100644 --- a/collects/meta/drdr/plt-build.rkt +++ b/collects/meta/drdr/plt-build.rkt @@ -60,7 +60,8 @@ (build-path log-dir "src" "build" "make") (make-path) (list "-j" (number->string (number-of-cpus)))) - (with-env (["PLT_SETUP_OPTIONS" (format "-j ~a" (number-of-cpus))]) + (with-env + (["PLT_SETUP_OPTIONS" (format "-j ~a" (number-of-cpus))]) (run/collect/wait/log #:timeout (current-make-install-timeout-seconds) #:env (current-env) @@ -82,11 +83,17 @@ (call-with-temporary-directory (lambda () e))) (define (call-with-temporary-home-directory thunk) - (define new-dir (make-temporary-file "home~a" 'directory (current-temporary-directory))) + (define new-dir + (make-temporary-file + "home~a" + 'directory + (current-temporary-directory))) (dynamic-wind (lambda () (with-handlers ([exn:fail? void]) - (copy-directory/files (hash-ref (current-env) "HOME") new-dir))) + (copy-directory/files + (hash-ref (current-env) "HOME") + new-dir))) (lambda () (with-env (["HOME" (path->string new-dir)]) (thunk))) @@ -169,86 +176,101 @@ (define test-workers (make-job-queue (number-of-cpus))) (define (test-directory dir-pth upper-sema) (define dir-log (build-path (trunk->log dir-pth) ".index.test")) - (if (read-cache* dir-log) - (semaphore-post upper-sema) - (let () - (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)) - (if directory? - (test-directory pth dir-sema) - (let () - (define log-pth (trunk->log pth)) - (if (file-exists? log-pth) - (semaphore-post dir-sema) - (let () - (define pth-timeout - (or (path-timeout pth) - (current-subprocess-timeout-seconds))) - (define pth-cmd/general (path-command-line pth)) - (define pth-cmd - (match pth-cmd/general - [#f - #f] - [(list-rest (or 'mzscheme 'racket) rst) - (lambda (k) (k (list* racket-path rst)))] - [(list-rest 'mzc rst) - (lambda (k) (k (list* mzc-path rst)))] - [(list-rest 'raco rst) - (lambda (k) (k (list* raco-path rst)))] - [(list-rest (or 'mred 'mred-text - 'gracket 'gracket-text) - rst) - (if (on-unix?) - (lambda (k) - (call-with-semaphore - gui-lock - (λ () - (k - (list* gracket-path - "-display" - (format ":~a" (cpu->child (current-worker))) - rst))))) - #f)] - [_ - #f])) - (if pth-cmd - (submit-job! - test-workers - (lambda () - (dynamic-wind - void - (λ () - (pth-cmd - (λ (l) - (with-env (["DISPLAY" (format ":~a" (cpu->child (current-worker)))]) - (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))))) - (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)))))) + (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? + (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)) + (define pth-cmd + (match pth-cmd/general + [#f + #f] + [(list-rest (or 'mzscheme 'racket) rst) + (lambda (k) + (k (list* racket-path rst)))] + [(list-rest 'mzc rst) + (lambda (k) (k (list* mzc-path rst)))] + [(list-rest 'raco rst) + (lambda (k) (k (list* raco-path rst)))] + [(list-rest (or 'mred 'mred-text + 'gracket 'gracket-text) + rst) + (if (on-unix?) + (lambda (k) + (call-with-semaphore + gui-lock + (λ () + (k + (list* gracket-path + "-display" + (format + ":~a" + (cpu->child + (current-worker))) + rst))))) + #f)] + [_ + #f])) + (cond + [pth-cmd + (submit-job! + test-workers + (lambda () + (dynamic-wind + void + (λ () + (pth-cmd + (λ (l) + (with-env + (["DISPLAY" + (format ":~a" + (cpu->child + (current-worker)))]) + (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 (planet-packages))]) (match pp @@ -267,7 +289,9 @@ #:env (current-env) (build-path log-dir "src" "build" "set-browser.rkt") racket-path - (list "-t" (path->string* (build-path (drdr-directory) "set-browser.rkt")))) + (list "-t" + (path->string* + (build-path (drdr-directory) "set-browser.rkt")))) ; And go (define top-sema (make-semaphore 0)) (notify! "Starting testing") @@ -292,9 +316,12 @@ (define (remove-X-locks tmp-dir i) (for ([dir (in-list (list "/tmp" tmp-dir))]) - (safely-delete-directory (build-path dir (format ".X~a-lock" i))) - (safely-delete-directory (build-path dir ".X11-unix" (format ".X~a-lock" i))) - (safely-delete-directory (build-path dir (format ".tX~a-lock" i))))) + (safely-delete-directory + (build-path dir (format ".X~a-lock" i))) + (safely-delete-directory + (build-path dir ".X11-unix" (format ".X~a-lock" i))) + (safely-delete-directory + (build-path dir (format ".tX~a-lock" i))))) (define (integrate-revision rev) (define test-dir @@ -323,7 +350,8 @@ ["TMPDIR" (path->string tmp-dir)] ["PATH" (format "~a:~a" - (path->string (build-path trunk-dir "bin")) + (path->string + (build-path trunk-dir "bin")) (getenv "PATH"))] ["PLTPLANETDIR" (path->string planet-dir)] ["HOME" (path->string home-dir)]) @@ -339,14 +367,20 @@ (with-running-program "/usr/bin/Xorg" (list (format ":~a" i)) (lambda () - (sleep 1) + (sleep 2) + (notify! "Starting fluxbox #~a" i) (with-running-program - (fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init") + (fluxbox-path) + (list "-display" + (format ":~a" i) + "-rc" "/home/pltdrdr/.fluxbox/init") inner)))) (start-x-server ROOTX (lambda () + (sleep 2) + (notify! "Starting test of rev ~a" rev) (test-revision rev))))) ; Remove the test directory (safely-delete-directory test-dir)))) diff --git a/collects/meta/drdr/render.rkt b/collects/meta/drdr/render.rkt index a8063835a5..3bd0ea6858 100644 --- a/collects/meta/drdr/render.rkt +++ b/collects/meta/drdr/render.rkt @@ -50,6 +50,8 @@ (local [(define end (newest-completed-revision))] (let loop ([rev (add1 (current-rev))]) (cond + [(not end) + #f] [(<= end rev) end] [(read-cache* (build-path (revision-dir rev) "analyzed")) @@ -80,19 +82,19 @@ (add-between (list* "DrDr" string-parts) " / ")) `(span (span ([class "breadcrumb"]) - ,(parent-a "/" "DrDr") " / " - ,@(add-between - (snoc - (for/list - ([sp (in-list (all-but-last string-parts))] - [from-root (in-naturals)]) - (define the-depth - (current-depth pth directory?)) - (parent-a - (to-index (- the-depth from-root)) sp)) - `(span ([class "this"]) - ,(last string-parts))) - " / ")) + ,(parent-a "/" "DrDr") " / " + ,@(add-between + (snoc + (for/list + ([sp (in-list (all-but-last string-parts))] + [from-root (in-naturals)]) + (define the-depth + (current-depth pth directory?)) + (parent-a + (to-index (- the-depth from-root)) sp)) + `(span ([class "this"]) + ,(last string-parts))) + " / ")) (span ([class "revnav"]) (a ([href ,prev-rev-url]) (img ([src "/images/rewind.png"]))) @@ -115,7 +117,7 @@ (format "http://github.com/plt/racket/commit/~a" end-commit) (format "http://github.com/plt/racket/compare/~a...~a" (git-push-previous-commit log) end-commit))) - + (define (format-commit-msg) (define pth (revision-commit-msg (current-rev))) (define (timestamp pth) @@ -193,51 +195,51 @@ path)) path)))))))]) commits))] - + [(struct svn-rev-log (num author date msg changes)) (define url (format "http://svn.racket-lang.org/view?view=rev&revision=~a" num)) (define cg-id (symbol->string (gensym 'changes))) (define ccss-id (symbol->string (gensym 'changes))) `(table ([class "data"]) - (tr ([class "author"]) (td "Author:") (td ,author)) - (tr ([class "date"]) - (td "Build Start:") - (td ,bdate/s)) - (tr ([class "date"]) (td "Build End:") (td ,bdate/e)) - (tr ([class "rev"]) - (td "Commit:") - (td (a ([href ,url]) ,(number->string num)))) - (tr ([class "date"]) - (td "Date:") - (td ,(svn-date->nice-date date))) - (tr ([class "msg"]) (td "Log:") (td (pre ,msg))) - (tr ([class "changes"]) - (td - (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" cg-id ccss-id)]) - (span ([id ,cg-id]) 9658) "Changes:")) - (td - (div ([id ,ccss-id] - [style "display: none;"]) - ,@(map (match-lambda - [(struct svn-change (action path)) - `(p ([class "output"]) - ,(symbol->string action) " " - ,(if (regexp-match #rx"^/trunk/collects" path) - (local [(define path-w/o-trunk - (apply build-path (list-tail (explode-path path) 2))) - (define html-path - (if (looks-like-directory? path) - (format "~a/" path-w/o-trunk) - path-w/o-trunk)) - (define path-url - (path->string* html-path)) - (define path-tested? - #t)] - (if path-tested? - `(a ([href ,path-url]) ,path) - path)) - path))]) - changes)))))] + (tr ([class "author"]) (td "Author:") (td ,author)) + (tr ([class "date"]) + (td "Build Start:") + (td ,bdate/s)) + (tr ([class "date"]) (td "Build End:") (td ,bdate/e)) + (tr ([class "rev"]) + (td "Commit:") + (td (a ([href ,url]) ,(number->string num)))) + (tr ([class "date"]) + (td "Date:") + (td ,(svn-date->nice-date date))) + (tr ([class "msg"]) (td "Log:") (td (pre ,msg))) + (tr ([class "changes"]) + (td + (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" cg-id ccss-id)]) + (span ([id ,cg-id]) 9658) "Changes:")) + (td + (div ([id ,ccss-id] + [style "display: none;"]) + ,@(map (match-lambda + [(struct svn-change (action path)) + `(p ([class "output"]) + ,(symbol->string action) " " + ,(if (regexp-match #rx"^/trunk/collects" path) + (local [(define path-w/o-trunk + (apply build-path (list-tail (explode-path path) 2))) + (define html-path + (if (looks-like-directory? path) + (format "~a/" path-w/o-trunk) + path-w/o-trunk)) + (define path-url + (path->string* html-path)) + (define path-tested? + #t)] + (if path-tested? + `(a ([href ,path-url]) ,path) + path)) + path))]) + changes)))))] [else '" "])) @@ -283,55 +285,56 @@ (define prev-rev-url (format "/~a~a" (previous-rev) the-base-path)) (define cur-rev-url (format "/~a~a" "current" the-base-path)) (define output (map render-event output-log)) - `(html (head (title ,title) - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "log, content"]) - ,breadcrumb - (table ([class "data"]) - (tr (td "Responsible:") - (td ,responsible)) - (tr (td "Command-line:") - (td ,@(add-between - (map (lambda (s) - `(span ([class "commandline"]) ,s)) - command-line) - " "))) - (tr (td "Duration:") (td ,(format-duration-ms dur) - nbsp (a ([href ,(format "/data~a" (path-add-suffix the-base-path #".timing"))]) - "(timing data)"))) - (tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity ""))) - (tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) ""))) - (tr (td " ") (td (a ([href ,scm-url]) "View File")))) - ,(if (lc-zero? changed) - "" - `(div ([class "error"]) - "This result of executing this file has changed since the previous push." - " " - (a ([href ,(format "/diff/~a/~a~a" (current-rev) (previous-rev) the-base-path)]) - "See the difference"))) - ,@(if (empty? output) - '() - `((div ([class "output"]) " " - ,@output))) - ,(with-handlers ([exn:fail? - ; XXX Remove this eventually - (lambda (x) - ; XXX use dirstruct functions - (define png-path - (format "/data~a" (path-add-suffix (path-add-suffix the-base-path #".timing") #".png"))) - `(div ([class "timing"]) - (a ([href ,png-path]) - (img ([src ,png-path])))))]) - (make-cdata - #f #f - (local [(define content - (file->string - (path-timing-html (substring (path->string* the-base-path) 1))))] - #;(regexp-replace* #rx"&(?![a-z]+;)" content "\\&\\1") - (regexp-replace* #rx">" content ">")) - )) - ,(footer))))])])) + (response/xexpr + `(html (head (title ,title) + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "log, content"]) + ,breadcrumb + (table ([class "data"]) + (tr (td "Responsible:") + (td ,responsible)) + (tr (td "Command-line:") + (td ,@(add-between + (map (lambda (s) + `(span ([class "commandline"]) ,s)) + command-line) + " "))) + (tr (td "Duration:") (td ,(format-duration-ms dur) + nbsp (a ([href ,(format "/data~a" (path-add-suffix the-base-path #".timing"))]) + "(timing data)"))) + (tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity ""))) + (tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) ""))) + (tr (td " ") (td (a ([href ,scm-url]) "View File")))) + ,(if (lc-zero? changed) + "" + `(div ([class "error"]) + "This result of executing this file has changed since the previous push." + " " + (a ([href ,(format "/diff/~a/~a~a" (current-rev) (previous-rev) the-base-path)]) + "See the difference"))) + ,@(if (empty? output) + '() + `((div ([class "output"]) " " + ,@output))) + ,(with-handlers ([exn:fail? + ; XXX Remove this eventually + (lambda (x) + ; XXX use dirstruct functions + (define png-path + (format "/data~a" (path-add-suffix (path-add-suffix the-base-path #".timing") #".png"))) + `(div ([class "timing"]) + (a ([href ,png-path]) + (img ([src ,png-path])))))]) + (make-cdata + #f #f + (local [(define content + (file->string + (path-timing-html (substring (path->string* the-base-path) 1))))] + #;(regexp-replace* #rx"&(?![a-z]+;)" content "\\&\\1") + (regexp-replace* #rx">" content ">")) + )) + ,(footer)))))])])) (define (number->string/zero v) (cond @@ -363,252 +366,257 @@ empty (cached-directory-list* dir-pth))) (define-values (title breadcrumb) (path->breadcrumb dir-pth #t)) - `(html (head (title ,title) - (script ([src "/sorttable.js"]) " ") - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "dirlog, content"]) - ,breadcrumb - ,(if show-commit-msg? + (response/xexpr + `(html (head (title ,title) + (script ([src "/sorttable.js"]) " ") + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "dirlog, content"]) + ,breadcrumb + ,(if show-commit-msg? (format-commit-msg) "") - - ; All files with a status - ,(let () - (define log-dir (revision-log-dir (current-rev))) - (define base-path - (rebase-path log-dir "/")) - `(div ([class "status"]) - (div ([class "tag"]) "by status") - ,@(for/list ([status (in-list responsible-ht-severity)] - [rendering->list-count (in-list (list rendering-timeout? rendering-unclean-exit? - rendering-stderr? rendering-changed?))]) - (define lc (rendering->list-count pth-rendering)) - (define rcss-id (symbol->string (gensym))) - (define rg-id (symbol->string (gensym 'glyph))) - - `(div (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" rg-id rcss-id)]) - (span ([id ,rg-id]) 9658) " " - ,(format "~a [~a]" - status - (lc->number lc))) - (ul ([id ,rcss-id] - [style ,(format "display: ~a" - "none")]) - ,@(for/list ([pp (lc->list lc)]) - (define p (bytes->string/utf-8 pp)) - (define bp (base-path p)) - `(li (a ([href ,(path->url bp)]) ,(path->string bp))))))))) - - ,(local [(define responsible->problems - (rendering->responsible-ht (current-rev) pth-rendering)) - (define last-responsible->problems - (with-handlers ([exn:fail? (lambda (x) (make-hash))]) - (define prev-dir-pth ((rebase-path (revision-log-dir (current-rev)) - (revision-log-dir (previous-rev))) - dir-pth)) - (define previous-pth-rendering - (parameterize ([current-rev (previous-rev)]) - (dir-rendering prev-dir-pth))) - (rendering->responsible-ht (previous-rev) previous-pth-rendering))) - (define new-responsible->problems - (responsible-ht-difference last-responsible->problems responsible->problems)) - - (define (render-responsible->problems tag responsible->problems) - (if (zero? (hash-count responsible->problems)) - "" - `(div ([class "status"]) - (div ([class "tag"]) ,tag) - ,@(for/list ([(responsible ht) (in-hash responsible->problems)]) - (define rcss-id (symbol->string (gensym))) - (define rg-id (symbol->string (gensym 'glyph))) - (define summary - (for/fold ([s ""]) - ([id (in-list responsible-ht-severity)]) - (define llc (hash-ref ht id empty)) - (if (empty? llc) - s - (format "~a [~a: ~a]" s id (length llc))))) - `(div (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" rg-id rcss-id)]) - (span ([id ,rg-id]) 9658) " " - ,responsible - " " ,summary) - (blockquote - ([id ,rcss-id] - [style "display: none;"]) - ,@(local [(define i 0)] - (for/list ([id (in-list responsible-ht-severity)]) - (define llc (hash-ref ht id empty)) - (if (empty? llc) - "" - (local [(define display? (< i 2)) - (define css-id (symbol->string (gensym 'ul))) - (define glyph-id (symbol->string (gensym 'glyph)))] - (set! i (add1 i)) - `(div (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" glyph-id css-id)]) - (span ([id ,glyph-id]) ,(if display? 9660 9658)) " " - ,(hash-ref responsible-ht-id->str id)) - (ul ([id ,css-id] - [style ,(format "display: ~a" - (if display? "block" "none"))]) - ,@(for/list ([p llc]) - `(li (a ([href ,(path->url p)]) ,(path->string p))))))))))))))))] - `(div ,(render-responsible->problems "all" responsible->problems) - ,(render-responsible->problems "new" new-responsible->problems))) - (table ([class "sortable, dirlist"]) - (thead - (tr (td "Path") - (td "Duration (Abs)") - (td "Duration (Sum)") - (td "Timeout?") - (td "Unclean Exit?") - (td "STDERR Output") - (td "Changes") - (td "Responsible"))) - (tbody - ,@(map (match-lambda - [(list directory? sub-pth (struct rendering (start end dur timeout unclean stderr responsible-party changes))) - (define name (path->string sub-pth)) - (define abs-dur (- end start)) - (define url - (if directory? - (format "~a/" name) - name)) - `(tr ([class ,(if directory? "dir" "file")] - [onclick ,(format "document.location = ~S" url)]) - (td ([sorttable_customkey - ,(format "~a:~a" - (if directory? "dir" "file") - name)]) - (a ([href ,url]) ,name ,(if directory? "/" ""))) - (td ([sorttable_customkey ,(number->string abs-dur)]) - ,(format-duration-ms abs-dur)) - (td ([sorttable_customkey ,(number->string dur)]) - ,(format-duration-ms dur)) - ,@(map (lambda (vv) - (define v (lc->number vv)) - `(td ([sorttable_customkey ,(number->string v)]) - ,(if directory? - (number->string/zero v) - (if (zero? v) - '" " - checkmark-entity)))) - (list timeout unclean stderr changes)) - (td ,responsible-party))]) - (sort files - (match-lambda* - [(list (list dir?1 name1 _) - (list dir?2 name2 _)) - (cond - [(and dir?1 dir?2) - (string<=? (path->string name1) - (path->string name2))] - [dir?1 #t] - [dir?2 #f])])))) - (tfoot - (tr ([class "total"]) - (td "Total") - (td ,(format-duration-ms (- tot-end tot-start))) - (td ,(format-duration-ms tot-dur)) - (td ,(number->string/zero (lc->number tot-timeout))) - (td ,(number->string/zero (lc->number tot-unclean))) - (td ,(number->string/zero (lc->number tot-stderr))) - (td ,(number->string/zero (lc->number tot-changes))) - (td " ")))) - ,(footer))))])) + + ; All files with a status + ,(let () + (define log-dir (revision-log-dir (current-rev))) + (define base-path + (rebase-path log-dir "/")) + `(div ([class "status"]) + (div ([class "tag"]) "by status") + ,@(for/list ([status (in-list responsible-ht-severity)] + [rendering->list-count (in-list (list rendering-timeout? rendering-unclean-exit? + rendering-stderr? rendering-changed?))]) + (define lc (rendering->list-count pth-rendering)) + (define rcss-id (symbol->string (gensym))) + (define rg-id (symbol->string (gensym 'glyph))) + + `(div (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" rg-id rcss-id)]) + (span ([id ,rg-id]) 9658) " " + ,(format "~a [~a]" + status + (lc->number lc))) + (ul ([id ,rcss-id] + [style ,(format "display: ~a" + "none")]) + ,@(for/list ([pp (lc->list lc)]) + (define p (bytes->string/utf-8 pp)) + (define bp (base-path p)) + `(li (a ([href ,(path->url bp)]) ,(path->string bp))))))))) + + ,(local [(define responsible->problems + (rendering->responsible-ht (current-rev) pth-rendering)) + (define last-responsible->problems + (with-handlers ([exn:fail? (lambda (x) (make-hash))]) + (define prev-dir-pth ((rebase-path (revision-log-dir (current-rev)) + (revision-log-dir (previous-rev))) + dir-pth)) + (define previous-pth-rendering + (parameterize ([current-rev (previous-rev)]) + (dir-rendering prev-dir-pth))) + (rendering->responsible-ht (previous-rev) previous-pth-rendering))) + (define new-responsible->problems + (responsible-ht-difference last-responsible->problems responsible->problems)) + + (define (render-responsible->problems tag responsible->problems) + (if (zero? (hash-count responsible->problems)) + "" + `(div ([class "status"]) + (div ([class "tag"]) ,tag) + ,@(for/list ([(responsible ht) (in-hash responsible->problems)]) + (define rcss-id (symbol->string (gensym))) + (define rg-id (symbol->string (gensym 'glyph))) + (define summary + (for/fold ([s ""]) + ([id (in-list responsible-ht-severity)]) + (define llc (hash-ref ht id empty)) + (if (empty? llc) + s + (format "~a [~a: ~a]" s id (length llc))))) + `(div (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" rg-id rcss-id)]) + (span ([id ,rg-id]) 9658) " " + ,responsible + " " ,summary) + (blockquote + ([id ,rcss-id] + [style "display: none;"]) + ,@(local [(define i 0)] + (for/list ([id (in-list responsible-ht-severity)]) + (define llc (hash-ref ht id empty)) + (if (empty? llc) + "" + (local [(define display? (< i 2)) + (define css-id (symbol->string (gensym 'ul))) + (define glyph-id (symbol->string (gensym 'glyph)))] + (set! i (add1 i)) + `(div (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" glyph-id css-id)]) + (span ([id ,glyph-id]) ,(if display? 9660 9658)) " " + ,(hash-ref responsible-ht-id->str id)) + (ul ([id ,css-id] + [style ,(format "display: ~a" + (if display? "block" "none"))]) + ,@(for/list ([p llc]) + `(li (a ([href ,(path->url p)]) ,(path->string p))))))))))))))))] + `(div ,(render-responsible->problems "all" responsible->problems) + ,(render-responsible->problems "new" new-responsible->problems))) + (table ([class "sortable, dirlist"]) + (thead + (tr (td "Path") + (td "Duration (Abs)") + (td "Duration (Sum)") + (td "Timeout?") + (td "Unclean Exit?") + (td "STDERR Output") + (td "Changes") + (td "Responsible"))) + (tbody + ,@(map (match-lambda + [(list directory? sub-pth (struct rendering (start end dur timeout unclean stderr responsible-party changes))) + (define name (path->string sub-pth)) + (define abs-dur (- end start)) + (define url + (if directory? + (format "~a/" name) + name)) + `(tr ([class ,(if directory? "dir" "file")] + [onclick ,(format "document.location = ~S" url)]) + (td ([sorttable_customkey + ,(format "~a:~a" + (if directory? "dir" "file") + name)]) + (a ([href ,url]) ,name ,(if directory? "/" ""))) + (td ([sorttable_customkey ,(number->string abs-dur)]) + ,(format-duration-ms abs-dur)) + (td ([sorttable_customkey ,(number->string dur)]) + ,(format-duration-ms dur)) + ,@(map (lambda (vv) + (define v (lc->number vv)) + `(td ([sorttable_customkey ,(number->string v)]) + ,(if directory? + (number->string/zero v) + (if (zero? v) + '" " + checkmark-entity)))) + (list timeout unclean stderr changes)) + (td ,responsible-party))]) + (sort files + (match-lambda* + [(list (list dir?1 name1 _) + (list dir?2 name2 _)) + (cond + [(and dir?1 dir?2) + (string<=? (path->string name1) + (path->string name2))] + [dir?1 #t] + [dir?2 #f])])))) + (tfoot + (tr ([class "total"]) + (td "Total") + (td ,(format-duration-ms (- tot-end tot-start))) + (td ,(format-duration-ms tot-dur)) + (td ,(number->string/zero (lc->number tot-timeout))) + (td ,(number->string/zero (lc->number tot-unclean))) + (td ,(number->string/zero (lc->number tot-stderr))) + (td ,(number->string/zero (lc->number tot-changes))) + (td " ")))) + ,(footer)))))])) (define (show-help req) - `(html - (head (title "DrDr > Help") - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "dirlog, content"]) - ; XXX Use same function as above - (span ([class "breadcrumb"]) - (a ([class "parent"] [href "/"]) "DrDr") " / " - (span ([class "this"]) - "Help")) - @div[[(class "help")]]{ - @h1{What is DrDr?} - @p{DrDr is a server at @a[[(href "http://www.byu.edu")]]{Brigham Young University} that builds - and "tests" every push to the Racket code base.} - - @h1{What kind of server?} - @p{A 64-bit Linux 2.6.32-25 server running Ubuntu 10.04.1 LTS with @,(number->string (number-of-cpus)) cores.} - - @h1{How is the build run?} - @p{Every push is built from a clean checkout with the standard separate build directory command sequence, except that @code{make} - is passed @code{-j} with the number of cores. Each push also has a fresh home directory and PLaneT cache.} - - @h1{How long does it take for a build to start after a check-in?} - @p{Only one build runs at a time and when none is running the git repository is polled every @,(number->string (current-monitoring-interval-seconds)) seconds.} - - @h1{How is the push "tested"?} - @p{Each file's @code{@,PROP:command-line} property is consulted. If it is the empty string, the file is ignored. If it is a string, then a single @code{~s} is replaced with the file's path, @code{racket}, @code{mzc}, @code{raco} with their path (for the current push), and @code{gracket} and @code{gracket-text} with @code{gracket}'s path (for the current push); then the resulting command-line is executed. - (Currently no other executables are allowed, so you can't @code{rm -fr /}.) - If there is no property value, the default @code{racket -qt ~s} is used if the file's suffix is @code{.rkt}, @code{.ss}, @code{.scm}, or @code{.scrbl} and @code{racket -f ~s} is used if the file's suffix is @code{.rktl}.} - - @p{The command-line is always executed with a fresh empty current directory which is removed after the run. But all the files share the same home directory and X server, which are both removed after each push's testing is complete.} - - @h1{How many files are "tested" concurrently?} - @p{One per core, or @,(number->string (number-of-cpus)).} - - @h1{How long may a file run?} - @p{The execution timeout is @,(number->string (current-subprocess-timeout-seconds)) seconds by default, but the @code{@,PROP:timeout} property is used if @code{string->number} returns a number on it.} - - @h1{May these settings be set on a per-directory basis?} - @p{Yes; if the property is set on any ancestor directory, then its value is used for its descendents when theirs is not set. - } - - @h1{What data is gathered during these runs?} - @p{When each file is run the following is recorded: the start time, the command-line, the STDERR and STDOUT output, the exit code (unless there is a timeout), and the end time. All this information is presented in the per-file DrDr report page.} - - @h1{How is the data analyzed?} - @p{From the data collected from the run, DrDr computes the total test time and whether output has "changed" since the last time the file was tested.} - - @h1{What output patterns constitute a "change"?} - @p{At the most basic level, if the bytes are different. However, there are two subtleties. First, DrDr knows to ignore the result of @code{time}. Second, the standard output and standard error streams are compared independently. The difference display pages present changed lines with a @span[([class "difference"])]{unique background}.} - - @h1{How is this site organized?} - @p{Each file's test results are displayed on a separate page, with a link to the previous push on changes. All the files in a directory are collated and indexed recursively. On these pages each column is sortable and each row is clickable. The root of a push also includes the git commit messages with links to the test results of the modified files. The top DrDr page displays the summary information for all the tested pushes.} - - @h1{What is the difference between @code{Duration (Abs)} and @code{Duration (Sum)}?} - @p{@code{Duration (Abs)} is the difference between the earliest start time and the latest end time in the collection.} - @p{@code{Duration (Sum)} is the sum of each file's difference between the start time and end time.} - @p{The two are often different because of parallelism in the testing process. (Long absolute durations indicate DrDr bugs waiting to get fixed.)} - - @h1{What do the graphs mean?} - @p{There is a single graph for each file, i.e., graphs are not kept for old pushs.} - @p{The X-axis is the tested push. The Y-axis is the percentage of the time of the slowest push.} - @p{The gray, horizontal lines show where 0%, 25%, 50%, 75%, and 100% are in the graph.} - @p{The black line shows the times for overall running of the file. The colored lines show the results from @code{time}. For each color, the "real" time is the darkest version of it and the "cpu" and "gc" time are 50% and 25% of the darkness, respectively.} - @p{If the number of calls to @code{time} change from one push to the next, then there is a gray, vertical bar at that point. Also, the scaling to the slowest time is specific to each horizontal chunk.} - @p{The graph is split up into panes that each contain approximately 300 pushes. The green arrowheads to the left - and right of the image move between panes.} - @p{The legend at the bottom of the graph shows the current pane, as well as the push number and any timing information from that push.} - @p{Click on the graph to jump to the DrDr page for a specific push.} - - @h1{What is the timing data format?} - @p{The timing files are a list of S-expressions. Their grammar is: @code{(push duration ((cpu real gc) ...))} where @code{push} is an integer, @code{duration} is an inexact millisecond, and @code{cpu}, @code{real}, and @code{gc} are parsed from the @code{time-apply} function.} + (response/xexpr + `(html + (head (title "DrDr > Help") + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "dirlog, content"]) + ; XXX Use same function as above + (span ([class "breadcrumb"]) + (a ([class "parent"] [href "/"]) "DrDr") " / " + (span ([class "this"]) + "Help")) + @div[[(class "help")]]{ + @h1{What is DrDr?} + @p{DrDr is a server at @a[[(href "http://www.byu.edu")]]{Brigham Young University} that builds + and "tests" every push to the Racket code base.} + + @h1{What kind of server?} + @p{A 64-bit Linux 2.6.32-25 server running Ubuntu 10.04.1 LTS with @,(number->string (number-of-cpus)) cores.} + + @h1{How is the build run?} + @p{Every push is built from a clean checkout with the standard separate build directory command sequence, except that @code{make} + is passed @code{-j} with the number of cores. Each push also has a fresh home directory and PLaneT cache.} + + @h1{How long does it take for a build to start after a check-in?} + @p{Only one build runs at a time and when none is running the git repository is polled every @,(number->string (current-monitoring-interval-seconds)) seconds.} + + @h1{How is the push "tested"?} + @p{Each file's @code{@,PROP:command-line} property is consulted. If it is the empty string, the file is ignored. If it is a string, then a single @code{~s} is replaced with the file's path, @code{racket}, @code{mzc}, @code{raco} with their path (for the current push), and @code{gracket} and @code{gracket-text} with @code{gracket}'s path (for the current push); then the resulting command-line is executed. + (Currently no other executables are allowed, so you can't @code{rm -fr /}.) + If there is no property value, the default @code{racket -qt ~s} is used if the file's suffix is @code{.rkt}, @code{.ss}, @code{.scm}, or @code{.scrbl} and @code{racket -f ~s} is used if the file's suffix is @code{.rktl}.} + + @p{The command-line is always executed with a fresh empty current directory which is removed after the run. But all the files share the same home directory and X server, which are both removed after each push's testing is complete.} + + @h1{How many files are "tested" concurrently?} + @p{One per core, or @,(number->string (number-of-cpus)).} + + @h1{How long may a file run?} + @p{The execution timeout is @,(number->string (current-subprocess-timeout-seconds)) seconds by default, but the @code{@,PROP:timeout} property is used if @code{string->number} returns a number on it.} + + @h1{May these settings be set on a per-directory basis?} + @p{Yes; if the property is set on any ancestor directory, then its value is used for its descendents when theirs is not set. + } + + @h1{What data is gathered during these runs?} + @p{When each file is run the following is recorded: the start time, the command-line, the STDERR and STDOUT output, the exit code (unless there is a timeout), and the end time. All this information is presented in the per-file DrDr report page.} + + @h1{How is the data analyzed?} + @p{From the data collected from the run, DrDr computes the total test time and whether output has "changed" since the last time the file was tested.} + + @h1{What output patterns constitute a "change"?} + @p{At the most basic level, if the bytes are different. However, there are two subtleties. First, DrDr knows to ignore the result of @code{time}. Second, the standard output and standard error streams are compared independently. The difference display pages present changed lines with a @span[([class "difference"])]{unique background}.} + + @h1{How is this site organized?} + @p{Each file's test results are displayed on a separate page, with a link to the previous push on changes. All the files in a directory are collated and indexed recursively. On these pages each column is sortable and each row is clickable. The root of a push also includes the git commit messages with links to the test results of the modified files. The top DrDr page displays the summary information for all the tested pushes.} + + @h1{What is the difference between @code{Duration (Abs)} and @code{Duration (Sum)}?} + @p{@code{Duration (Abs)} is the difference between the earliest start time and the latest end time in the collection.} + @p{@code{Duration (Sum)} is the sum of each file's difference between the start time and end time.} + @p{The two are often different because of parallelism in the testing process. (Long absolute durations indicate DrDr bugs waiting to get fixed.)} + + @h1{What do the graphs mean?} + @p{There is a single graph for each file, i.e., graphs are not kept for old pushs.} + @p{The X-axis is the tested push. The Y-axis is the percentage of the time of the slowest push.} + @p{The gray, horizontal lines show where 0%, 25%, 50%, 75%, and 100% are in the graph.} + @p{The black line shows the times for overall running of the file. The colored lines show the results from @code{time}. For each color, the "real" time is the darkest version of it and the "cpu" and "gc" time are 50% and 25% of the darkness, respectively.} + @p{If the number of calls to @code{time} change from one push to the next, then there is a gray, vertical bar at that point. Also, the scaling to the slowest time is specific to each horizontal chunk.} + @p{The graph is split up into panes that each contain approximately 300 pushes. The green arrowheads to the left + and right of the image move between panes.} + @p{The legend at the bottom of the graph shows the current pane, as well as the push number and any timing information from that push.} + @p{Click on the graph to jump to the DrDr page for a specific push.} + + @h1{What is the timing data format?} + @p{The timing files are a list of S-expressions. Their grammar is: @code{(push duration ((cpu real gc) ...))} where @code{push} is an integer, @code{duration} is an inexact millisecond, and @code{cpu}, @code{real}, and @code{gc} are parsed from the @code{time-apply} function.} + + @h1{Why are some pushes missing?} + @p{Some pushes are missing because they only modify branches. Only pushes that change the @code{master} branch are tested.} + + @h1{How do I make the most use of DrDr?} + @p{So DrDr can be effective with all testing packages and untested code, it only pays attention to error output and non-zero exit codes. You can make the most of this strategy by ensuring that when your tests are run successfully they have no STDERR output and exit cleanly, but have both when they fail.} + + @h1{How do I fix the reporting of an error in my code?} + @p{If you know you code does not have a bug, but DrDr thinks it does, you can probably fix it by setting its properties: allow it to run longer with @code{@,PROP:timeout} (but be kind and perhaps change the program to support work load selection on the command-line) or make sure it is run with the right command-line using @code{@,PROP:command-line}.} + + @h1{How can I do the most for DrDr?} + @p{The most important thing you can do is eliminate false positives by configuring DrDr for your code and removing spurious error output.} + @p{The next thing is to structure your code so DrDr does not do the same work many times. For example, because DrDr will load every file if your test suite is broken up into different parts that execute when loaded @em{and} they are all loaded by some other file, then DrDr will load and run them twice. The recommended solution is to have DrDr ignore the combining file or change it so a command-line argument is needed to run everything but is not provided by DrDr, that way the combining code is compiled but the tests are run once.} + + } + ,(footer)))))) - @h1{Why are some pushes missing?} - @p{Some pushes are missing because they only modify branches. Only pushes that change the @code{master} branch are tested.} - - @h1{How do I make the most use of DrDr?} - @p{So DrDr can be effective with all testing packages and untested code, it only pays attention to error output and non-zero exit codes. You can make the most of this strategy by ensuring that when your tests are run successfully they have no STDERR output and exit cleanly, but have both when they fail.} - - @h1{How do I fix the reporting of an error in my code?} - @p{If you know you code does not have a bug, but DrDr thinks it does, you can probably fix it by setting its properties: allow it to run longer with @code{@,PROP:timeout} (but be kind and perhaps change the program to support work load selection on the command-line) or make sure it is run with the right command-line using @code{@,PROP:command-line}.} - - @h1{How can I do the most for DrDr?} - @p{The most important thing you can do is eliminate false positives by configuring DrDr for your code and removing spurious error output.} - @p{The next thing is to structure your code so DrDr does not do the same work many times. For example, because DrDr will load every file if your test suite is broken up into different parts that execute when loaded @em{and} they are all loaded by some other file, then DrDr will load and run them twice. The recommended solution is to have DrDr ignore the combining file or change it so a command-line argument is needed to run everything but is not provided by DrDr, that way the combining code is compiled but the tests are run once.} - - } - ,(footer))))) +(define (take* l i) + (take l (min (length l) i))) (define (list-limit len offset l) - (take (drop l offset) len)) + (take* (drop l offset) len)) (define (string-first-line s) (define v @@ -662,114 +670,115 @@ (append future-revs built-or-building-revs)) (define how-many-total-revs (length all-revs)) - `(html - (head (title "DrDr") - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "dirlog, content"]) - ; XXX Use same function as above - (span ([class "breadcrumb"]) - (span ([class "this"]) - "DrDr")) - (table ([class "dirlist"]) - (thead - (tr (td "Push#") - (td "Duration (Abs)") - (td "Duration (Sum)") - (td "Timeout?") - (td "Unclean Exit?") - (td "STDERR Output") - (td "Changes") - (td "Pusher"))) - (tbody - ,@(map (match-lambda - [(cons 'future rev-pth) - (define name (path->string rev-pth)) - (define rev (string->number name)) - (define log (read-cache (future-record-path rev))) - (define-values (committer title) - (log->committer+title log)) - (define url (log->url log)) - `(tr ([class "dir"] - [title ,title]) - (td (a ([href ,url]) ,name)) - (td ([class "building"] [colspan "6"]) - "") - (td ([class "author"]) ,committer))] - [(cons 'past rev-pth) - (define name (path->string rev-pth)) - (define url (format "~a/" name)) - (define rev (string->number name)) - (define log-pth (revision-commit-msg rev)) - (define log (read-cache log-pth)) - (define-values (committer title) - (log->committer+title log)) - (define (no-rendering-row) - (define mtime - (file-or-directory-modify-seconds log-pth)) - - `(tr ([class "dir"] - [title ,title]) - (td (a ([href "#"]) ,name)) - (td ([class "building"] [colspan "6"]) - "Build in progress. Started " - ,(format-duration-m - (/ (- (current-seconds) mtime) 60)) - " ago.") - (td ([class "author"]) ,committer))) - (parameterize ([current-rev rev]) - (with-handlers - ([(lambda (x) - (regexp-match #rx"No cache available" (exn-message x))) - (lambda (x) - (no-rendering-row))]) - ; XXX One function to generate - (match (dir-rendering (revision-log-dir rev)) - [#f - (no-rendering-row)] - [(struct rendering - (start end dur timeout unclean - stderr responsible-party changes)) - (define abs-dur (- end start)) - - `(tr ([class "dir"] - [title ,title] - [onclick ,(format "document.location = ~S" url)]) - (td (a ([href ,url]) ,name)) - (td ([sorttable_customkey ,(number->string abs-dur)]) - ,(format-duration-ms abs-dur)) - (td ([sorttable_customkey ,(number->string dur)]) - ,(format-duration-ms dur)) - ,@(map (lambda (vv) - (define v (lc->number vv)) - `(td ([sorttable_customkey ,(number->string v)]) - ,(number->string/zero v))) - (list timeout unclean stderr changes)) - (td ,responsible-party))])))]) - (list-limit - how-many-revs offset - all-revs)))) - (table ([id "revnav"] [width "100%"]) - (tr (td ([align "left"]) - (span ([class "revnav"]) - (a ([href ,(top-url show-revisions)]) - (img ([src "/images/skip-backward1.png"]))) - (a ([href ,(format "~a?offset=~a" - (top-url show-revisions) - (max 0 (- offset how-many-revs)))]) - (img ([src "/images/rewind.png"]))))) - (td ([align "right"]) - (span ([class "revnav"]) - (a ([href ,(format "~a?offset=~a" - (top-url show-revisions) - (min (- how-many-total-revs how-many-revs) - (+ offset how-many-revs)))]) - (img ([src "/images/fast-forward.png"]))) - (a ([href ,(format "~a?offset=~a" - (top-url show-revisions) - (- how-many-total-revs how-many-revs))]) - (img ([src "/images/skip-forward1.png"]))))))) - ,(footer))))) + (response/xexpr + `(html + (head (title "DrDr") + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "dirlog, content"]) + ; XXX Use same function as above + (span ([class "breadcrumb"]) + (span ([class "this"]) + "DrDr")) + (table ([class "dirlist"]) + (thead + (tr (td "Push#") + (td "Duration (Abs)") + (td "Duration (Sum)") + (td "Timeout?") + (td "Unclean Exit?") + (td "STDERR Output") + (td "Changes") + (td "Pusher"))) + (tbody + ,@(map (match-lambda + [(cons 'future rev-pth) + (define name (path->string rev-pth)) + (define rev (string->number name)) + (define log (read-cache (future-record-path rev))) + (define-values (committer title) + (log->committer+title log)) + (define url (log->url log)) + `(tr ([class "dir"] + [title ,title]) + (td (a ([href ,url]) ,name)) + (td ([class "building"] [colspan "6"]) + "") + (td ([class "author"]) ,committer))] + [(cons 'past rev-pth) + (define name (path->string rev-pth)) + (define url (format "~a/" name)) + (define rev (string->number name)) + (define log-pth (revision-commit-msg rev)) + (define log (read-cache log-pth)) + (define-values (committer title) + (log->committer+title log)) + (define (no-rendering-row) + (define mtime + (file-or-directory-modify-seconds log-pth)) + + `(tr ([class "dir"] + [title ,title]) + (td (a ([href "#"]) ,name)) + (td ([class "building"] [colspan "6"]) + "Build in progress. Started " + ,(format-duration-m + (/ (- (current-seconds) mtime) 60)) + " ago.") + (td ([class "author"]) ,committer))) + (parameterize ([current-rev rev]) + (with-handlers + ([(lambda (x) + (regexp-match #rx"No cache available" (exn-message x))) + (lambda (x) + (no-rendering-row))]) + ; XXX One function to generate + (match (dir-rendering (revision-log-dir rev)) + [#f + (no-rendering-row)] + [(struct rendering + (start end dur timeout unclean + stderr responsible-party changes)) + (define abs-dur (- end start)) + + `(tr ([class "dir"] + [title ,title] + [onclick ,(format "document.location = ~S" url)]) + (td (a ([href ,url]) ,name)) + (td ([sorttable_customkey ,(number->string abs-dur)]) + ,(format-duration-ms abs-dur)) + (td ([sorttable_customkey ,(number->string dur)]) + ,(format-duration-ms dur)) + ,@(map (lambda (vv) + (define v (lc->number vv)) + `(td ([sorttable_customkey ,(number->string v)]) + ,(number->string/zero v))) + (list timeout unclean stderr changes)) + (td ,responsible-party))])))]) + (list-limit + how-many-revs offset + all-revs)))) + (table ([id "revnav"] [width "100%"]) + (tr (td ([align "left"]) + (span ([class "revnav"]) + (a ([href ,(top-url show-revisions)]) + (img ([src "/images/skip-backward1.png"]))) + (a ([href ,(format "~a?offset=~a" + (top-url show-revisions) + (max 0 (- offset how-many-revs)))]) + (img ([src "/images/rewind.png"]))))) + (td ([align "right"]) + (span ([class "revnav"]) + (a ([href ,(format "~a?offset=~a" + (top-url show-revisions) + (min (- how-many-total-revs how-many-revs) + (+ offset how-many-revs)))]) + (img ([src "/images/fast-forward.png"]))) + (a ([href ,(format "~a?offset=~a" + (top-url show-revisions) + (- how-many-total-revs how-many-revs))]) + (img ([src "/images/skip-forward1.png"]))))))) + ,(footer)))))) (define (show-revision req rev) (define log-dir (revision-log-dir rev)) @@ -783,37 +792,40 @@ (define (file-not-found file-pth) (define-values (title breadcrumb) (path->breadcrumb file-pth #f)) - `(html - (head (title ,title " > Not Found") - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "content"]) - ,breadcrumb - (div ([class "error"]) - "This file does not exist in push #" ,(number->string (current-rev)) " or has not been tested.") - ,(footer))))) + (response/xexpr + `(html + (head (title ,title " > Not Found") + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "content"]) + ,breadcrumb + (div ([class "error"]) + "This file does not exist in push #" ,(number->string (current-rev)) " or has not been tested.") + ,(footer)))))) (define (dir-not-found dir-pth) (define-values (title breadcrumb) (path->breadcrumb dir-pth #t)) - `(html - (head (title ,title " > Not Found") - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "content"]) - ,breadcrumb - (div ([class "error"]) - "This directory does not exist in push #" ,(number->string (current-rev)) " or has not been tested.") - ,(footer))))) + (response/xexpr + `(html + (head (title ,title " > Not Found") + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "content"]) + ,breadcrumb + (div ([class "error"]) + "This directory does not exist in push #" ,(number->string (current-rev)) " or has not been tested.") + ,(footer)))))) (define (rev-not-found dir-pth path-to-file) (define-values (title breadcrumb) (path->breadcrumb dir-pth #t)) - `(html - (head (title ,title " > Not Found") - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "content"]) - ,breadcrumb - (div ([class "error"]) - "Push #" ,(number->string (current-rev)) " does not exist or has not been tested.") - ,(footer))))) + (response/xexpr + `(html + (head (title ,title " > Not Found") + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "content"]) + ,breadcrumb + (div ([class "error"]) + "Push #" ,(number->string (current-rev)) " does not exist or has not been tested.") + ,(footer)))))) (define (find-previous-rev this-rev) (if (zero? this-rev) @@ -874,31 +886,32 @@ (format "DrDr / File Difference / ~a (~a:~a)" f-str r1 r2)) - `(html (head (title ,title) - (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) - (body - (div ([class "log, content"]) - (span ([class "breadcrumb"]) - (a ([class "parent"] [href "/"]) - "DrDr") - " / " - (span ([class "this"]) - "File Difference")) - (table ([class "data"]) - (tr (td "First Push:") (td (a ([href ,(format "/~a/~a" r1 f-str)]) ,(number->string r1)))) - (tr (td "Second Push:") (td (a ([href ,(format "/~a/~a" r2 f-str)]) ,(number->string r2)))) - (tr (td "File:") (td "/" ,f-str))) - (div ([class "output"]) - (table ([class "diff"]) - ,@(for/list ([d (in-list (render-log-difference l1 l2))]) - (match d - [(struct difference (old new)) - `(tr ([class "difference"]) - (td ,(render-event old)) - (td ,(render-event new)))] - [(struct same-itude (e)) - `(tr (td ([colspan "2"]) ,(render-event e)))])))) - ,(footer))))))) + (response/xexpr + `(html (head (title ,title) + (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) + (body + (div ([class "log, content"]) + (span ([class "breadcrumb"]) + (a ([class "parent"] [href "/"]) + "DrDr") + " / " + (span ([class "this"]) + "File Difference")) + (table ([class "data"]) + (tr (td "First Push:") (td (a ([href ,(format "/~a/~a" r1 f-str)]) ,(number->string r1)))) + (tr (td "Second Push:") (td (a ([href ,(format "/~a/~a" r2 f-str)]) ,(number->string r2)))) + (tr (td "File:") (td "/" ,f-str))) + (div ([class "output"]) + (table ([class "diff"]) + ,@(for/list ([d (in-list (render-log-difference l1 l2))]) + (match d + [(struct difference (old new)) + `(tr ([class "difference"]) + (td ,(render-event old)) + (td ,(render-event new)))] + [(struct same-itude (e)) + `(tr (td ([colspan "2"]) ,(render-event e)))])))) + ,(footer)))))))) (define-values (top-dispatch top-url) (dispatch-rules @@ -910,18 +923,27 @@ [((integer-arg) "") show-revision] [((integer-arg) (string-arg) ...) show-file])) -#;(define (xml-dispatch req) - (define xe (top-dispatch req)) - (define full - (make-xexpr-response xe #:mime-type #"application/xhtml+xml")) - (struct-copy response/full full - [body (list* - #"\n" - (response/full-body full))])) +(require (only-in net/url url->string)) +(define (log-dispatch req) + (define user-agent + (cond + [(headers-assq #"User-Agent" + (request-headers/raw req)) + => header-value] + [else + #"Unknown"])) + (cond + [(regexp-match #"Googlebot" user-agent) + (response/xexpr "Please, do not index.")] + [else + (printf "~a - ~a\n" + (url->string (request-uri req)) + user-agent) + (top-dispatch req)])) (date-display-format 'iso-8601) (cache/file-mode 'no-cache) -(serve/servlet top-dispatch +(serve/servlet log-dispatch #:port 9000 #:listen-ip #f #:quit? #f diff --git a/collects/meta/drdr/static/robots.txt b/collects/meta/drdr/static/robots.txt new file mode 100644 index 0000000000..1a3761aa8b --- /dev/null +++ b/collects/meta/drdr/static/robots.txt @@ -0,0 +1,3 @@ +# go away +User-agent: * +Disallow: /