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))
(define committer
(with-handlers ([exn:fail? (lambda (x) #f)])
(svn-rev-log-author
(scm-commit-author
(read-cache*
(revision-commit-msg cur-rev)))))
(define diff
@ -317,7 +317,7 @@
(or
(and committer?
(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))
"unknown"))

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

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

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

@ -80,6 +80,20 @@
(define-syntax-rule (with-temporary-directory 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-values (new-command new-args)
(command+args+env->command+args
@ -185,14 +199,14 @@
test-workers
(lambda ()
(define l (pth-cmd))
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]
["HOME" (make-fresh-home-dir)])
(with-temporary-directory
(run/collect/wait/log log-pth
#:timeout pth-timeout
#:env (current-env)
(first l)
(rest l))))
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (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)))))))
files)
@ -229,12 +243,6 @@
(notify! "Stopping testing")
(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)
(if (zero? i)
(f)

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

@ -99,55 +99,101 @@
(define (svn-date->nice-date date)
(regexp-replace "^(....-..-..)T(..:..:..).*Z$" date "\\1 \\2"))
(define (git-date->nice-date date)
(regexp-replace "^(....-..-..) (..:..:..).*$" date "\\1 \\2"))
(define (format-commit-msg)
(define pth (revision-commit-msg (current-rev)))
(define msg-v (read-cache* pth))
(match msg-v
; XXX git push
(define (timestamp pth)
(with-handlers ([exn:fail? (lambda (x) "")])
(date->string (seconds->date (read-cache (build-path (revision-dir (current-rev)) pth))) #t)))
(define bdate/s (timestamp "checkout-done"))
(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 (timestamp pth)
(with-handlers ([exn:fail? (lambda (x) "")])
(date->string (seconds->date (read-cache (build-path (revision-dir (current-rev)) pth))) #t)))
(define bdate/s (timestamp "checkout-done"))
(define bdate/e (timestamp "integrated"))
(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 "Commit Date:") (td ,(svn-date->nice-date date)))
(tr ([class "date"]) (td "Build Start:") (td ,bdate/s))
(tr ([class "date"]) (td "Build End:") (td ,bdate/e))
(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 (td nbsp) (td (a ([href ,url]) "View Commit"))))]
(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
'nbsp]))
@ -184,11 +230,16 @@
(define-values (title breadcrumb) (path->breadcrumb log-pth #f))
(define the-base-path
(base-path log-pth))
; XXX git url
(define svn-url
(format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a"
the-base-path
(current-rev)))
(define scm-url
(if ((current-rev) . < . 20000)
(format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a"
the-base-path
(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 cur-rev-url (format "/~a~a" "current" the-base-path))
(define output (map render-event output-log))
@ -209,7 +260,7 @@
(tr (td "Duration:") (td ,(format-duration-ms dur)))
(tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity "")))
(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)
""
`(div ([class "error"])
@ -270,8 +321,8 @@
(div ([class "dirlog, content"])
,breadcrumb
,(if show-commit-msg?
(format-commit-msg)
"")
(format-commit-msg)
"")
,(local [(define (path->url pth)
(format "http://drdr.plt-scheme.org/~a~a" (current-rev) pth))

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

@ -135,14 +135,30 @@
[to string?])]
[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 commit
(push-data-end-commit (push-info rev)))
(define cmd
(format "~S archive --format=tar ~S ~S | tar -O -xf - ~S > ~S"
(git-path) commit file file dest))
(parameterize ([current-directory repo])
(system cmd))
(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-checkout rev repo dest)
@ -168,6 +184,6 @@
(provide/contract
[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-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)])