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

Finalizing git transition

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-22 13:06:40 -06:00
parent b5d2496544
commit 09164a2027
5 changed files with 147 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/meta/drdr/analyze.ss
View File

@ -129,7 +129,7 @@
responsible)) responsible))
(define committer (define committer
(with-handlers ([exn:fail? (lambda (x) #f)]) (with-handlers ([exn:fail? (lambda (x) #f)])
(svn-rev-log-author (scm-commit-author
(read-cache* (read-cache*
(revision-commit-msg cur-rev))))) (revision-commit-msg cur-rev)))))
(define diff (define diff
@ -317,7 +317,7 @@
(or (or
(and committer? (and committer?
(with-handlers ([exn:fail? (lambda (x) #f)]) (with-handlers ([exn:fail? (lambda (x) #f)])
(svn-rev-log-author (read-cache (revision-commit-msg (current-rev)))))) (scm-commit-author (read-cache (revision-commit-msg (current-rev))))))
(or (path-responsible (trunk-path dir-pth)) (or (path-responsible (trunk-path dir-pth))
"unknown")) "unknown"))

2
collects/meta/drdr/monitor-scm.ss
View File

@ -31,7 +31,7 @@
[current-monitoring-interval-seconds [current-monitoring-interval-seconds
(parameter/c exact-nonnegative-integer?)] (parameter/c exact-nonnegative-integer?)]
[monitor-scm [monitor-scm
(string? exact-nonnegative-integer? (path-string? exact-nonnegative-integer?
((listof exact-nonnegative-integer?) . -> . void) ((listof exact-nonnegative-integer?) . -> . void)
(exact-nonnegative-integer? exact-nonnegative-integer? . -> . void) (exact-nonnegative-integer? exact-nonnegative-integer? . -> . void)
. -> . any)]) . -> . any)])

26
collects/meta/drdr/plt-build.ss
View File

@ -80,6 +80,20 @@
(define-syntax-rule (with-temporary-directory e) (define-syntax-rule (with-temporary-directory e)
(call-with-temporary-directory (lambda () e))) (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)))
(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) (define (with-running-program command args thunk)
(define-values (new-command new-args) (define-values (new-command new-args)
(command+args+env->command+args (command+args+env->command+args
@ -185,14 +199,14 @@
test-workers test-workers
(lambda () (lambda ()
(define l (pth-cmd)) (define l (pth-cmd))
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))] (with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))])
["HOME" (make-fresh-home-dir)]) (with-temporary-home-directory
(with-temporary-directory (with-temporary-directory
(run/collect/wait/log log-pth (run/collect/wait/log log-pth
#:timeout pth-timeout #:timeout pth-timeout
#:env (current-env) #:env (current-env)
(first l) (first l)
(rest l)))) (rest l)))))
(semaphore-post dir-sema))) (semaphore-post dir-sema)))
(semaphore-post dir-sema))))))) (semaphore-post dir-sema)))))))
files) files)
@ -229,12 +243,6 @@
(notify! "Stopping testing") (notify! "Stopping testing")
(stop-job-queue! test-workers)) (stop-job-queue! test-workers))
(define (make-fresh-home-dir)
(define new-dir (make-temporary-file "home~a" 'directory (current-temporary-directory)))
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") new-dir))
(path->string new-dir))
(define (recur-many i r f) (define (recur-many i r f)
(if (zero? i) (if (zero? i)
(f) (f)

75
collects/meta/drdr/render.ss
View File

@ -99,26 +99,73 @@
(define (svn-date->nice-date date) (define (svn-date->nice-date date)
(regexp-replace "^(....-..-..)T(..:..:..).*Z$" date "\\1 \\2")) (regexp-replace "^(....-..-..)T(..:..:..).*Z$" date "\\1 \\2"))
(define (git-date->nice-date date)
(regexp-replace "^(....-..-..) (..:..:..).*$" date "\\1 \\2"))
(define (format-commit-msg) (define (format-commit-msg)
(define pth (revision-commit-msg (current-rev))) (define pth (revision-commit-msg (current-rev)))
(define msg-v (read-cache* pth))
(match msg-v
; XXX git push
[(struct svn-rev-log (num author date msg changes))
(define url (format "http://svn.plt-scheme.org/view?view=rev&revision=~a" num))
(define (timestamp pth) (define (timestamp pth)
(with-handlers ([exn:fail? (lambda (x) "")]) (with-handlers ([exn:fail? (lambda (x) "")])
(date->string (seconds->date (read-cache (build-path (revision-dir (current-rev)) pth))) #t))) (date->string (seconds->date (read-cache (build-path (revision-dir (current-rev)) pth))) #t)))
(define bdate/s (timestamp "checkout-done")) (define bdate/s (timestamp "checkout-done"))
(define bdate/e (timestamp "integrated")) (define bdate/e (timestamp "integrated"))
(match (read-cache* pth)
[(struct git-push (num author commits))
`(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))
,@(append-map
(match-lambda
[(struct git-merge (hash author date msg from to))
`((tr ([class "hash"]) (td "Commit:") (td (a ([href ,(format "http://github.com/plt/racket/commit/~a" hash)]) ,hash)))
(tr ([class "date"]) (td "Date:") (td ,(git-date->nice-date date)))
(tr ([class "author"]) (td "Author:") (td ,author))
(tr ([class "msg"]) (td "Log:") (td (pre ,@msg)))
(tr ([class "merge"]) (td "Merge:") (td "From " ,from " to " ,to)))]
[(struct git-diff (hash author date msg mfiles))
(define cg-id (symbol->string (gensym 'changes)))
(define ccss-id (symbol->string (gensym 'changes)))
`((tr ([class "hash"]) (td "Commit:") (td (a ([href ,(format "http://github.com/plt/racket/commit/~a" hash)]) ,hash)))
(tr ([class "date"]) (td "Date:") (td ,(git-date->nice-date date)))
(tr ([class "author"]) (td "Author:") (td ,author))
(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;"])
,@(for/list ([path (in-list mfiles)])
`(p ([class "output"])
,(if (regexp-match #rx"^collects" path)
(local [(define path-w/o-trunk
(apply build-path (explode-path path)))
(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)))))))])
commits))]
[(struct svn-rev-log (num author date msg changes))
(define url (format "http://svn.plt-scheme.org/view?view=rev&revision=~a" num))
(define cg-id (symbol->string (gensym 'changes))) (define cg-id (symbol->string (gensym 'changes)))
(define ccss-id (symbol->string (gensym 'changes))) (define ccss-id (symbol->string (gensym 'changes)))
`(table ([class "data"]) `(table ([class "data"])
(tr ([class "author"]) (td "Author:") (td ,author)) (tr ([class "author"]) (td "Author:") (td ,author))
(tr ([class "date"]) (td "Commit Date:") (td ,(svn-date->nice-date date)))
(tr ([class "date"]) (td "Build Start:") (td ,bdate/s)) (tr ([class "date"]) (td "Build Start:") (td ,bdate/s))
(tr ([class "date"]) (td "Build End:") (td ,bdate/e)) (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 "msg"]) (td "Log:") (td (pre ,msg)))
(tr ([class "changes"]) (tr ([class "changes"])
(td (td
@ -146,8 +193,7 @@
`(a ([href ,path-url]) ,path) `(a ([href ,path-url]) ,path)
path)) path))
path))]) path))])
changes)))) changes)))))]
(tr (td nbsp) (td (a ([href ,url]) "View Commit"))))]
[else [else
'nbsp])) 'nbsp]))
@ -184,11 +230,16 @@
(define-values (title breadcrumb) (path->breadcrumb log-pth #f)) (define-values (title breadcrumb) (path->breadcrumb log-pth #f))
(define the-base-path (define the-base-path
(base-path log-pth)) (base-path log-pth))
; XXX git url (define scm-url
(define svn-url (if ((current-rev) . < . 20000)
(format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a" (format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a"
the-base-path the-base-path
(current-rev))) (current-rev))
(local [(define msg (read-cache* (revision-commit-msg (current-rev))))]
(if msg
(format "http://github.com/plt/racket/blob/~a~a"
(git-push-end-commit msg) the-base-path)
"#"))))
(define prev-rev-url (format "/~a~a" (previous-rev) the-base-path)) (define prev-rev-url (format "/~a~a" (previous-rev) the-base-path))
(define cur-rev-url (format "/~a~a" "current" the-base-path)) (define cur-rev-url (format "/~a~a" "current" the-base-path))
(define output (map render-event output-log)) (define output (map render-event output-log))
@ -209,7 +260,7 @@
(tr (td "Duration:") (td ,(format-duration-ms dur))) (tr (td "Duration:") (td ,(format-duration-ms dur)))
(tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity ""))) (tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity "")))
(tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) ""))) (tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) "")))
(tr (td nbsp) (td (a ([href ,svn-url]) "View File")))) (tr (td nbsp) (td (a ([href ,scm-url]) "View File"))))
,(if (lc-zero? changed) ,(if (lc-zero? changed)
"" ""
`(div ([class "error"]) `(div ([class "error"])

26
collects/meta/drdr/scm.ss
View File

@ -135,14 +135,30 @@
[to string?])] [to string?])]
[get-scm-commit-msg (exact-nonnegative-integer? path-string? . -> . git-push?)]) [get-scm-commit-msg (exact-nonnegative-integer? path-string? . -> . git-push?)])
(define (git-push-end-commit gp)
(git-commit-hash (first (git-push-commits gp))))
(provide/contract
[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 rev repo file dest) (define (scm-export rev repo file dest)
(define commit (define commit
(push-data-end-commit (push-info rev))) (push-data-end-commit (push-info rev)))
(define cmd (call-with-output-file*
(format "~S archive --format=tar ~S ~S | tar -O -xf - ~S > ~S" dest
(git-path) commit file file dest)) #:exists 'truncate/replace
(lambda (file-port)
(parameterize ([current-directory repo]) (parameterize ([current-directory repo])
(system cmd)) (system/output-port
#:k void
#:stdout file-port
(git-path) "--no-pager" "show" (format "~a:~a" commit file)))))
(void)) (void))
(define (scm-checkout rev repo dest) (define (scm-checkout rev repo dest)
@ -168,6 +184,6 @@
(provide/contract (provide/contract
[scm-update (path? . -> . void?)] [scm-update (path? . -> . void?)]
[scm-revisions-after (exact-nonnegative-integer? . -> . void?)] [scm-revisions-after (exact-nonnegative-integer? . -> . (listof exact-nonnegative-integer?))]
[scm-export (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)] [scm-export (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)]
[scm-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)]) [scm-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)])