137 lines
4.5 KiB
Racket
137 lines
4.5 KiB
Racket
#lang racket/base
|
|
(require net/url
|
|
racket/system
|
|
racket/function
|
|
racket/list
|
|
racket/match
|
|
racket/port
|
|
racket/contract
|
|
"../lib/scm.rkt")
|
|
|
|
(define git-path (find-executable-path "git"))
|
|
(define git-url-base "http://git.racket-lang.org/plt.git")
|
|
(define (get-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)))
|
|
|
|
(struct push-data (who end-commit branches) #:prefab)
|
|
|
|
(define (get-push-data 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]+)$" (list _ who end-commit))
|
|
(regexp #rx"^([0-9abcdef]+) +([0-9abcdef]+) +(.+)$" (list _ bstart bend branch))
|
|
...)
|
|
(push-data who end-commit
|
|
(make-immutable-hash
|
|
(map (lambda (b bs be) (cons b (vector bs be)))
|
|
branch bstart bend)))]
|
|
[_
|
|
#f]))
|
|
|
|
(define (close-input-port* p)
|
|
(when p (close-input-port p)))
|
|
(define (close-output-port* p)
|
|
(when p (close-output-port p)))
|
|
|
|
(define (system/output-port #:k k #:stdout [init-stdout #f] . as)
|
|
(define-values (sp stdout stdin stderr)
|
|
(apply subprocess init-stdout #f #f as))
|
|
(begin0 (k stdout)
|
|
(subprocess-wait sp)
|
|
(subprocess-kill sp #t)
|
|
(close-input-port* stdout)
|
|
(close-output-port* stdin)
|
|
(close-input-port* stderr)))
|
|
|
|
(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 (read-line in-p)
|
|
[(? eof-object?)
|
|
#f]
|
|
[(regexp #rx"^commit +(.+)$" (list _ hash))
|
|
(match (read-line in-p)
|
|
[(regexp #rx"^Merge: +(.+) +(.+)$" (list _ from to))
|
|
(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))
|
|
(git-merge hash author date msg from to)]
|
|
[(regexp #rx"^Author: +(.+)$" (list _ author))
|
|
(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))
|
|
(git-diff hash author date msg mfiles)])]))
|
|
|
|
(define master-branch "refs/heads/master")
|
|
(define (git-pushes-after cur-rev)
|
|
(define newest-rev (get-newest-push))
|
|
(for/list ([rev (in-range (add1 cur-rev) (add1 newest-rev))]
|
|
#:when
|
|
(let ([info (get-push-data rev)])
|
|
(and info (hash-has-key? (push-data-branches info) master-branch))))
|
|
rev))
|
|
|
|
(define (git-update repo)
|
|
(parameterize ([current-directory repo])
|
|
(system* git-path "fetch" git-url-base))
|
|
(void))
|
|
|
|
(define (read-commits in-p)
|
|
(cond
|
|
[(port-closed? in-p)
|
|
empty]
|
|
[(read-commit in-p)
|
|
=> (lambda (c)
|
|
(printf "~S\n" c)
|
|
(list* c (read-commits in-p)))]
|
|
[else
|
|
empty]))
|
|
(define (parse-push repo num author in-p)
|
|
(define commits (read-commits in-p))
|
|
(define start (git-commit-hash (last commits)))
|
|
(define previous-commit
|
|
(parameterize ([current-directory repo])
|
|
(system/output-port
|
|
#:k (λ (port) (read-line port))
|
|
git-path "--no-pager" "log" "--format=format:%P" start "-1")))
|
|
(git-push num author previous-commit commits))
|
|
|
|
(define (get-git-push repo rev)
|
|
(match-define (push-data who _ branches) (get-push-data rev))
|
|
(match-define (vector start-commit end-commit) (hash-ref branches master-branch))
|
|
(parameterize ([current-directory repo])
|
|
(system/output-port
|
|
#:k (curry parse-push repo rev who)
|
|
git-path
|
|
"--no-pager" "log" "--date=iso" "--name-only" "--no-merges"
|
|
(format "~a..~a" start-commit end-commit))))
|
|
|
|
(provide/contract
|
|
[git-pushes-after (exact-nonnegative-integer? . -> . (listof exact-nonnegative-integer?))]
|
|
[git-update (path? . -> . void?)]
|
|
[get-git-push (path? exact-nonnegative-integer? . -> . git-push?)])
|