From 09164a2027107b21ee463ba4343013073d1f9d82 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 22 Apr 2010 13:06:40 -0600 Subject: [PATCH] Finalizing git transition --- collects/meta/drdr/analyze.ss | 4 +- collects/meta/drdr/monitor-scm.ss | 2 +- collects/meta/drdr/plt-build.ss | 36 +++++--- collects/meta/drdr/render.ss | 149 ++++++++++++++++++++---------- collects/meta/drdr/scm.ss | 28 ++++-- 5 files changed, 147 insertions(+), 72 deletions(-) diff --git a/collects/meta/drdr/analyze.ss b/collects/meta/drdr/analyze.ss index fa79f0e7f5..f29cf3ba6c 100644 --- a/collects/meta/drdr/analyze.ss +++ b/collects/meta/drdr/analyze.ss @@ -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")) diff --git a/collects/meta/drdr/monitor-scm.ss b/collects/meta/drdr/monitor-scm.ss index 267cc7b4e8..da1875b893 100644 --- a/collects/meta/drdr/monitor-scm.ss +++ b/collects/meta/drdr/monitor-scm.ss @@ -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)]) \ No newline at end of file diff --git a/collects/meta/drdr/plt-build.ss b/collects/meta/drdr/plt-build.ss index 7477ccb24f..f9749c8af9 100644 --- a/collects/meta/drdr/plt-build.ss +++ b/collects/meta/drdr/plt-build.ss @@ -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) diff --git a/collects/meta/drdr/render.ss b/collects/meta/drdr/render.ss index 65683b1bf6..6e521f7674 100644 --- a/collects/meta/drdr/render.ss +++ b/collects/meta/drdr/render.ss @@ -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)) diff --git a/collects/meta/drdr/scm.ss b/collects/meta/drdr/scm.ss index 9932289f4b..ec47204cb3 100644 --- a/collects/meta/drdr/scm.ss +++ b/collects/meta/drdr/scm.ss @@ -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?)]) \ No newline at end of file