Forgot to add the git extraction code.
This commit is contained in:
parent
56820287ac
commit
ad6d703225
59
collects/meta/web/download/release-info.rkt
Normal file
59
collects/meta/web/download/release-info.rkt
Normal file
|
@ -0,0 +1,59 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require racket/system racket/port racket/match racket/runtime-path)
|
||||||
|
|
||||||
|
(define-runtime-path THIS-GIT "../../../../.git")
|
||||||
|
|
||||||
|
(define (warn fmt . xs)
|
||||||
|
(eprintf "Warning: ~a\a\n" (apply format fmt xs))
|
||||||
|
(flush-output (current-error-port))
|
||||||
|
(sleep 1)
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(define git
|
||||||
|
(let* ([exe (or (find-executable-path "git")
|
||||||
|
(warn "no `git' executable => no release info"))]
|
||||||
|
[try (lambda (dir) (and dir (directory-exists? dir) dir))]
|
||||||
|
[dir (and exe (or (ormap try (list (getenv "GIT_DIR") THIS-GIT))
|
||||||
|
(warn "no git dir found => no release info\n (~a)"
|
||||||
|
"set $GIT_DIR to a racket repo .git dir")))]
|
||||||
|
[nowhere (open-output-nowhere)])
|
||||||
|
(and dir
|
||||||
|
(lambda args
|
||||||
|
(define o (open-output-string))
|
||||||
|
(parameterize ([current-directory dir]
|
||||||
|
[current-output-port o]
|
||||||
|
[current-error-port nowhere])
|
||||||
|
(and (apply system* exe "--no-pager" args)
|
||||||
|
(get-output-string o)))))))
|
||||||
|
|
||||||
|
(provide get-version-tag-info)
|
||||||
|
(define (get-version-tag-info version)
|
||||||
|
(let/ec return
|
||||||
|
(unless git (return #f))
|
||||||
|
(define (bad . args) (apply warn args) (return #f))
|
||||||
|
(define (try fmt)
|
||||||
|
(let* ([tag (format fmt version)]
|
||||||
|
[text (and (git "cat-file" "-e" tag)
|
||||||
|
(git "cat-file" "tag" tag))])
|
||||||
|
(and text (cons tag text))))
|
||||||
|
(let* ([text (or (try "v~a") (try "old-v~a")
|
||||||
|
(bad "no git info for ~s (missing tag)" version))]
|
||||||
|
[tag (car text)]
|
||||||
|
[text (cdr text)]
|
||||||
|
[check (lambda (x) (or x (bad "malformed git info for ~s" tag)))]
|
||||||
|
[sep (check (regexp-match-positions #rx"\n\n" text))]
|
||||||
|
[meta (map (lambda (h)
|
||||||
|
(let ([m (check (regexp-match-positions #rx" " h))])
|
||||||
|
(list (string->symbol (substring h 0 (caar m)))
|
||||||
|
(substring h (cdar m)))))
|
||||||
|
(regexp-split #rx"\n" (substring text 0 (caar sep))))]
|
||||||
|
[text (substring text (cdar sep))])
|
||||||
|
(match meta
|
||||||
|
[`((object ,_) (type "commit") (tag ,_)
|
||||||
|
(tagger ,(regexp #rx"^(.* <.*>) ([0-9]+) ([-+]?[0-9][0-9])00$"
|
||||||
|
(list _ tagger date ofs))))
|
||||||
|
;; ignore the time offset (it probably depends on where the tag
|
||||||
|
;; was made)
|
||||||
|
(list tagger (seconds->date (string->number date)) text)]
|
||||||
|
[_ (check #f)]))))
|
Loading…
Reference in New Issue
Block a user