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

Moving to Git

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-21 16:24:59 -06:00
parent 0acfa7e525
commit 3c76137124
10 changed files with 174 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
#lang scheme
(require scheme/file
"diff.ss"
"svn.ss"
"scm.ss"
"list-count.ss"
"notify.ss"
"cache.ss"

6
collects/meta/drdr/config.ss
View File

@ -2,12 +2,12 @@
(require "cache.ss"
"dirstruct.ss"
"svn.ss"
"monitor-svn.ss")
"scm.ss"
"monitor-scm.ss")
(plt-directory "/opt/plt")
(drdr-directory "/opt/svn/drdr")
(svn-path "/usr/bin/svn")
(git-path "/usr/bin/git")
(Xvfb-path "/usr/bin/Xvfb")
(current-make-install-timeout-seconds (* 60 60))
(current-make-timeout-seconds (* 60 60))

6
collects/meta/drdr/dirstruct.ss
View File

@ -31,8 +31,8 @@
(define fluxbox-path
(make-parameter "/usr/bin/fluxbox"))
(define plt-repository
(make-parameter "http://svn.plt-scheme.org/plt/trunk"))
(define (plt-repository)
(build-path (plt-directory) "repo"))
(define current-make-timeout-seconds
(make-parameter (* 60 30)))
@ -96,7 +96,7 @@
[make-path (parameter/c string?)]
[Xvfb-path (parameter/c string?)]
[fluxbox-path (parameter/c string?)]
[plt-repository (parameter/c string?)]
[plt-repository (-> path?)]
[path-timing-log (path-string? . -> . path?)]
[path-timing-png (path-string? . -> . path?)]
[path-timing-png-prefix (path-string? . -> . path?)]

18
collects/meta/drdr/main.ss
View File

@ -3,12 +3,12 @@
(require scheme/system
"dirstruct.ss"
"analyze.ss"
"monitor-svn.ss"
"monitor-scm.ss"
"notify.ss"
"retry.ss"
"config.ss"
"plt-build.ss"
"svn.ss"
"scm.ss"
"cache.ss"
"path-utils.ss")
@ -55,15 +55,15 @@
(notify! "Last revision is r~a" cur-rev)
(handle-revision prev-rev cur-rev)
(notify! "Starting to monitor SVN @ r~a" cur-rev)
(monitor-svn (plt-repository)
(notify! "Starting to monitor @ r~a" cur-rev)
(monitor-scm (plt-repository)
cur-rev
(lambda (newer)
(for ([l (in-list newer)])
(write-cache! (future-record-path (svn-rev-log-num l)) l)))
(lambda (prev-rev cur-rev _log)
(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)
))
(exit 0)))

14
collects/meta/drdr/metadata.ss
View File

@ -1,8 +1,7 @@
#lang scheme
(require "path-utils.ss"
"dirstruct.ss"
"svn.ss"
scheme/system)
"scm.ss")
(define (testable-file? pth)
(define suffix (filename-extension pth))
@ -54,12 +53,11 @@
(define tmp-file (make-temporary-file "props~a.ss"))
(and
; Checkout the props file
(system* (svn-path)
"export"
"--quiet"
"-r" (number->string rev)
(format "~a/collects/meta/props" (plt-repository))
(path->string tmp-file))
(scm-export
rev
(plt-repository)
"collects/meta/props"
tmp-file)
; Dynamic require it
(begin0
(dynamic-require `(file ,(path->string tmp-file))

25
collects/meta/drdr/monitor-svn.ss → collects/meta/drdr/monitor-scm.ss
View File

@ -1,30 +1,25 @@
#lang scheme
(require "svn.ss"
(require "scm.ss"
"retry.ss")
(define current-monitoring-interval-seconds
(make-parameter 60))
(define (monitor-svn repos start-rev notify-newer! notify-user!)
(define (monitor-scm repos start-rev notify-newer! notify-user!)
(define (monitor-w/o-wait prev-rev)
(define all-logs
(svn-revision-logs-after prev-rev repos))
(define new-logs
(filter-not
(lambda (l) (= (svn-rev-log-num l) prev-rev))
all-logs))
(match new-logs
(define new-revs
(scm-revisions-after prev-rev repos))
(match new-revs
[(list)
; There has not yet been more revisions
(monitor prev-rev)]
[(cons log newer)
(define new-rev (svn-rev-log-num log))
[(cons new-rev newer)
; 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 log))
(notify-user! prev-rev new-rev))
(monitor new-rev)]))
(define (monitor prev-rev)
(sleep (current-monitoring-interval-seconds))
@ -34,8 +29,8 @@
(provide/contract
[current-monitoring-interval-seconds
(parameter/c exact-nonnegative-integer?)]
[monitor-svn
[monitor-scm
(string? exact-nonnegative-integer?
((listof svn-rev-log?) . -> . void)
(exact-nonnegative-integer? exact-nonnegative-integer? svn-rev-log? . -> . void)
((listof exact-nonnegative-integer?) . -> . void)
(exact-nonnegative-integer? exact-nonnegative-integer? . -> . void)
. -> . any)])

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

@ -10,7 +10,7 @@
"notify.ss"
"path-utils.ss"
"sema.ss"
"svn.ss")
"scm.ss")
(define current-env (make-parameter (make-immutable-hash empty)))
(define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...)
@ -43,18 +43,7 @@
(path->string co-dir))]
(notify! "Checking out ~a@~a into ~a"
repo rev to-dir)
(run/collect/wait/log
; XXX Give it its own timeout
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "svn-checkout")
(svn-path)
(list
"checkout"
"--quiet"
"-r" (number->string rev)
repo
to-dir)))))
(scm-checkout rev repo to-dir))))
;; Make the build directory
(make-directory* build-dir)
;; Run Configure, Make, Make Install
@ -285,7 +274,7 @@
["HOME" (path->string home-dir)])
(unless (read-cache* (revision-commit-msg rev))
(write-cache! (revision-commit-msg rev)
(svn-revision-log rev (plt-repository))))
(get-scm-commit-msg rev (plt-repository))))
(build-revision rev)
(recur-many (number-of-cpus)
(lambda (j inner)

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

@ -5,12 +5,11 @@
"config.ss"
"diff.ss"
"list-count.ss"
"svn.ss"
"cache.ss"
(except-in "dirstruct.ss"
revision-trunk-dir)
"status.ss"
"monitor-svn.ss"
"monitor-scm.ss"
(only-in "metadata.ss"
PROP:command-line
PROP:timeout)
@ -489,7 +488,8 @@
(require web-server/servlet-env
web-server/http
web-server/dispatch)
web-server/dispatch
"scm.ss")
(define how-many-revs 45)
(define (show-revisions req)
(define builds-pth (plt-build-directory))

136
collects/meta/drdr/scm.ss Normal file
View File

@ -0,0 +1,136 @@
#lang scheme
(require "svn.ss"
net/url
scheme/system)
(provide
(all-from-out "svn.ss"))
(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")
(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 start-commit 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]+) +([0-9abcdef]+)$" (list _ who start-commit end-commit))
(regexp #rx"^([0-9abcdef]+) +([0-9abcdef]+) +(.+)$" (list _ _ _ branch))
...)
(make-push-data who start-commit end-commit branch)]
[_
#f]))
(define (system/output-port #:stdout [init-stdout #f] . as)
(define-values (sp stdout stdin stderr)
(apply subprocess init-stdout #f #f as))
(subprocess-wait sp)
stdout)
(define-struct git-push (num author commits) #:prefab)
(define-struct git-commit (hash author date msg mfiles) #: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 in-p)
(match-define (regexp #rx"^commit +(.+)$" (list _ hash)) (read-line in-p))
(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))
(define mfiles (read-until-empty-line in-p))
(make-git-commit hash author date msg mfiles))
(define port-empty? port-closed?)
(define (read-commits in-p)
(if (port-empty? in-p)
empty
(list* (read-commit in-p)
(read-commits in-p))))
(define (parse-push num author in-p)
(make-git-push num author (read-commits in-p)))
(define (get-scm-commit-msg rev repo)
(match-define (struct push-data (who start-commit end-commit branches)) (push-info rev))
(scm-update repo)
(parse-push
rev who
(parameterize ([current-directory repo])
(system/output-port (git-path) "log" "--date=iso" "--name-only" (format "~a..~a" start-commit end-commit)))))
(provide/contract
[struct git-push ([num exact-nonnegative-integer?]
[author string?]
[commits (listof git-commit?)])]
[struct git-commit ([hash string?]
[author string?]
[date string?]
[msg (listof string?)]
[mfiles (listof string?)])]
[get-scm-commit-msg (exact-nonnegative-integer? string? . -> . git-push?)])
(define (scm-export rev repo file dest)
(define commit
(push-data-end-commit (push-info rev)))
(scm-update repo)
(call-with-output-file*
dest
#:exists 'truncate/replace
(lambda (file-port)
(parameterize ([current-directory repo])
(system/output-port #:stdout file-port
(git-path)
"archive" commit file))))
(void))
(define (scm-checkout rev repo dest)
(scm-update repo)
(system* (git-path) "clone" (path->string repo) (path->string dest))
(parameterize ([current-directory dest])
(system* (git-path) "checkout" (push-data-end-commit (push-info rev)))))
(define (scm-update repo)
(parameterize ([current-directory repo])
(system* (git-path) "fetch" git-url-base)))
(define (scm-revisions-after cur-rev repo)
(define newest-rev (newest-push))
(for/list ([rev (in-range (add1 cur-rev) newest-rev)]
#:when
(let ([info (push-info rev)])
(and info
(member "refs/heads/master" (push-data-branches info)))))
rev))
(provide/contract
[scm-revisions-after (exact-nonnegative-integer? path? . -> . void?)]
[scm-export (exact-nonnegative-integer? path? string? path? . -> . void?)]
[scm-checkout (exact-nonnegative-integer? path? path? . -> . void?)])

119
collects/meta/drdr/svn.ss
View File

@ -1,130 +1,11 @@
#lang scheme
(require xml
"notify.ss")
(define svn-path
(make-parameter "/opt/local/bin/svn"))
;; Running SVN w/ XML parsing
(define (svn/xml-parse . in-args)
(define args
(list* "--xml" in-args))
(define-values
(the-process stdout stdin stderr)
(apply
subprocess
#f #f #f
(svn-path)
args))
#;(notify! "Parsing SVN XML output: ~a ~a" (svn-path) args)
(begin0
(dynamic-wind void
(lambda ()
(with-handlers ([exn:xml? (lambda (x) x)])
(parameterize ([collapse-whitespace #t]
[xexpr-drop-empty-attributes #t])
(xml->xexpr (document-element (read-xml stdout))))))
(lambda ()
(close-input-port stdout)))
(close-output-port stdin)
(close-input-port stderr)
(sync the-process
(handle-evt (alarm-evt (+ (current-inexact-milliseconds) (* 1000 2)))
(lambda (_)
(subprocess-kill the-process #t)
#f)))))
;;; Finding out about SVN revisions
(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)
(define (svn-revision-log-xml rev trunk)
(notify! "Getting log file for r~a in ~a" rev trunk)
(svn/xml-parse
"log"
"-r" rev
"-v"
#;"--with-all-revprops" ; v1.5
trunk))
(define parse-log-entry
(match-lambda
[`(logentry ((revision ,rev)) " "
(author ,author) " "
(date ,date) " "
(paths ,path ...)
" " (msg . ,msg) " ")
(make-svn-rev-log
(string->number rev)
author date (apply string-append msg)
(filter-map (match-lambda
[`(path ((action ,action) . ,any) ,file)
(make-svn-change (string->symbol action) file)]
[" "
#f])
path))]
[" " #f]))
(define parse-svn-log-xml
(match-lambda
[(? exn:fail? x)
(fprintf (current-error-port) "Error: ~a" (exn-message x))
#f]
[`(log " ")
(make-svn-rev-nolog)]
[`(log
" " ,le " ")
(parse-log-entry le)]))
(define (svn-revision-log rev trunk)
(define rev-string
(cond
[(number? rev) (number->string rev)]
[(symbol? rev)
(case rev
[(HEAD) "HEAD"])]))
(parse-svn-log-xml
(svn-revision-log-xml rev-string trunk)))
(define (svn-revision-logs-after-xml rev trunk)
(notify! "Getting logs for revision after r~a in ~a" rev trunk)
(svn/xml-parse
"log"
"-r" (format "~a:HEAD" rev)
"-v"
#;"--with-all-revprops" ; v1.5
trunk))
(define (parse-svn-logs-xml xexpr)
(match xexpr
[(? exn:fail? x)
(fprintf (current-error-port) "Error: ~a" (exn-message x))
empty]
[`(log " ")
empty]
[`(log . ,les)
(filter-map parse-log-entry les)]))
(define (svn-revision-logs-after rev trunk)
(parse-svn-logs-xml
(svn-revision-logs-after-xml rev trunk)))
(provide/contract
[svn-path (parameter/c string?)]
[svn-revision-log
((or/c exact-nonnegative-integer? (symbols 'HEAD))
string?
. -> .
(or/c false/c
svn-rev?))]
[svn-revision-logs-after
(exact-nonnegative-integer?
string?
. -> .
(listof svn-rev-log?))]
[struct svn-rev ()]
[struct (svn-rev-nolog svn-rev) ()]
[struct (svn-rev-log svn-rev)