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

git-checkout: add support for 'head as a ref

Browse Source 
Also, change the default ref from "master" to 'head. This is
technically a backward-incompatible change, but so far it seems more
likely to make things work right than to break them.
This commit is contained in:
Matthew Flatt 2021-02-19 09:42:10 -07:00
parent 19c3ee456b
commit f0e41cf143
2 changed files with 87 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/net-doc/net/scribblings/git-checkout.scrbl
View File

@ -22,7 +22,7 @@ for information on command-line arguments and flags.
@defproc[(git-checkout [hostname string?] @defproc[(git-checkout [hostname string?]
[repository string?] [repository string?]
[#:dest-dir dest-dir (or/c path-string? #f)] [#:dest-dir dest-dir (or/c path-string? #f)]
[#:ref ref string? "master"] [#:ref ref (or/c string? 'head) 'head]
[#:transport transport (or/c 'git 'http 'https) 'git] [#:transport transport (or/c 'git 'http 'https) 'git]
[#:depth depth (or/c #f exact-positive-integer?) 1] [#:depth depth (or/c #f exact-positive-integer?) 1]
[#:status-printf status-printf (string? any/c ... . -> . void?) (lambda args [#:status-printf status-printf (string? any/c ... . -> . void?) (lambda args
@ -41,14 +41,15 @@ for information on command-line arguments and flags.
[#:password password (or/c string? #f) (current-git-password)]) [#:password password (or/c string? #f) (current-git-password)])
string?]{ string?]{
Contacts the server at @racket[hostname] and @racket[port] Contacts the server at @racket[hostname] and @racket[port] (where
(where @racket[#f] is replaced by the default) @racket[#f] is replaced by the default) to download the repository
to download the repository whose name on the server is whose name on the server is @racket[repository] (normally ending in
@racket[repository] (normally ending in @filepath{.git}). The tree @filepath{.git}). The tree within the repository that is identified by
within the repository that is identified by @racket[ref] (which can be @racket[ref] is extracted to @racket[dest-dir], and it returns a
a branch, tag, commit ID, or tree ID) is extracted to string containing a commit ID corresponding to @racket[ref]. The
@racket[dest-dir], and it returns a string containing a commit ID corresponding @racket[ref] argument can be a string for a branch, tag, commit ID, or
to @racket[ref]. tree ID, or it can be @racket['head] to refer to the default branch as
reported by the server.
If @racket[transport] is @racket['git], then the server is contacted If @racket[transport] is @racket['git], then the server is contacted
using Git's native transport. If @racket[transport] is using Git's native transport. If @racket[transport] is
@ -69,8 +70,8 @@ If @racket[dest-dir] does not exist, it is created. If
@racket[dest-dir] does exist, its existing content is left in place @racket[dest-dir] does exist, its existing content is left in place
except as replaced by content from the Git repository. except as replaced by content from the Git repository.
If @racket[ref] identifies a branch or tag by either name or by If @racket[ref] identifies a branch or tag by name, through @racket['head], or
commit ID, then the @tt{git://} protocol allows @racket[git-checkout] by its commit ID, then the @tt{git://} protocol allows @racket[git-checkout]
to download only the commits and objects relevant to the branch or to download only the commits and objects relevant to the branch or
tag. Furthermore, the default @racket[depth] argument allows tag. Furthermore, the default @racket[depth] argument allows
@racket[git-checkout] to obtain only the latest commit and its @racket[git-checkout] to obtain only the latest commit and its
@ -109,7 +110,9 @@ Authentication.
#:changed "6.2.900.17" @elem{Added the @racket[strict-links?] argument.} #:changed "6.2.900.17" @elem{Added the @racket[strict-links?] argument.}
#:changed "6.6.0.5" @elem{Added the @racket[username] and @racket[password] arguments.} #:changed "6.6.0.5" @elem{Added the @racket[username] and @racket[password] arguments.}
#:changed "6.6.0.5" @elem{Changed to raise @racket[exn:fail:git] exceptions #:changed "6.6.0.5" @elem{Changed to raise @racket[exn:fail:git] exceptions
instead of @racket[exn:fail].}]} instead of @racket[exn:fail].}
#:changed "8.0.0.8" @elem{Added support for @racket[ref] as @racket['head]
and made @racket['head] the default.}]}
@deftogether[(@defparam[current-git-username username (or/c string? #f)] @deftogether[(@defparam[current-git-username username (or/c string? #f)]
@defparam[current-git-password password (or/c string? #f)])]{ @defparam[current-git-password password (or/c string? #f)])]{

77
racket/collects/net/git-checkout.rkt
View File

@ -38,7 +38,7 @@
repo repo
#:dest-dir dest-dir ; #f => only find checkout #:dest-dir dest-dir ; #f => only find checkout
#:transport [transport 'git] #:transport [transport 'git]
#:ref [ref "master"] #:ref [ref/head 'head]
#:depth [given-depth 1] #:depth [given-depth 1]
#:status-printf [status-printf (lambda args #:status-printf [status-printf (lambda args
(apply printf args) (apply printf args)
@ -76,7 +76,7 @@
"git-upload-pack " "/" repo "\0" "git-upload-pack " "/" repo "\0"
"host=" host "\0") "host=" host "\0")
(define pkts (if dumb-protocol? (define pkts (if dumb-protocol?
;; dumb protocol provide plain lines: ;; dumb protocol provides plain lines:
(for/list ([l (in-lines i)]) (string-append l "\n")) (for/list ([l (in-lines i)]) (string-append l "\n"))
;; smart protocol provides packets: ;; smart protocol provides packets:
(read-pkts i))) (read-pkts i)))
@ -88,10 +88,15 @@
(define refs ; (list (list <name> <ID>) ...) (define refs ; (list (list <name> <ID>) ...)
(parse-initial-refs pkts initial-error)) (parse-initial-refs pkts initial-error))
(define ref (head->ref ref/head
server-capabilities dumb-protocol?
transport host verify? port repo username password
status))
;; Find the commits needed for `ref`: ;; Find the commits needed for `ref`:
(define-values (ref-commit ; #f or an ID string (define-values (ref-commit ; #f or an ID string
want-commits) ; list of ID string want-commits) ; list of ID string
(select-commits ref refs status try-only-master? repo)) (select-commits ref refs server-capabilities status try-only-master? repo))
(unless dest-dir (unless dest-dir
(write-pkt o) ; clean termination (write-pkt o) ; clean termination
@ -313,6 +318,39 @@
(list "Content-Type: application/x-git-upload-pack-request"))))) (list "Content-Type: application/x-git-upload-pack-request")))))
(values i (open-output-nowhere))])) (values i (open-output-nowhere))]))
;; converts 'head to a branch/tag/commit ref
(define (head->ref ref/head
server-capabilities dumb-protocol?
transport host verify? port repo username password
status)
(cond
[(eq? ref/head 'head)
(or
;; Git 1.8.5 and later (smart protocol) maps HEAD in capabilities
(for/or ([cap (in-list server-capabilities)])
(define m (regexp-match #rx"^symref=HEAD:(.*)$" cap))
(and m (refspec->ref (cadr m))))
;; dumb protocol: fetch the "HEAD" reference
(case (and dumb-protocol? transport)
[(http https)
(status "Getting HEAD")
(define i
(parameterize ([current-https-protocol (ssl-context verify?)])
(get-pure-port
(string->url
(~a transport "://" host ":" port "/" repo
"/HEAD"))
(append
(http-request-headers username password)
(list "Content-Type: application/x-git-upload-pack-request")))))
(define s (port->string i))
(define m (regexp-match #rx"(?m:^ref: (.*)$)" s))
(and m (refspec->ref (cadr m)))]
[else #f])
;; If all else fails, keep 'head and try to match "HEAD" in refs
'head)]
[else ref/head]))
(define (ssl-context verify?) (define (ssl-context verify?)
(cond (cond
[(or (not verify?) [(or (not verify?)
@ -321,6 +359,12 @@
[else [else
'secure])) 'secure]))
(define (refspec->ref refspec)
(cond
[(regexp-match #rx"^refs/(?:heads|tags)/(.*)$" refspec)
=> (lambda (m) (cadr m))]
[else refspec]))
;; ---------------------------------------- ;; ----------------------------------------
;; parse-server-capabilities : bytes -> (listof string) ;; parse-server-capabilities : bytes -> (listof string)
@ -349,20 +393,28 @@
#f] #f]
[else (list name id)])))) [else (list name id)]))))
;; select-commits : string (listof (list bytes string)) ;; select-commits : (or/c string 'head) (listof (list bytes string)) ....
;; -> (values string-or-#f (listof string)) ;; -> (values string-or-#f (listof string))
;; Convert the user's request `ref`, which is a branch or tag or ID, ;; Convert the user's request `ref`, which is a branch or tag or ID,
;; into a specific ID --- if we can determine it from the server's ;; into a specific ID --- if we can determine it from the server's
;; initial response. If we can, the list of requested IDs will be ;; initial response. If we can, the list of requested IDs will be
;; just that one. Otherwise, we'll have to return a list of all ;; just that one. Otherwise, we'll have to return a list of all
;; IDs, and then we'll look for the reference later. ;; IDs, and then we'll look for the reference later.
(define (select-commits ref refs status try-only-master? repo) (define (select-commits ref refs server-capabilities status try-only-master? repo)
(define ref-looks-like-id? (regexp-match? #rx"^[0-9a-f]+$" ref)) (define ref-looks-like-id? (and (string? ref)
(regexp-match? #rx"^[0-9a-f]+$" ref)))
(define ref-rx (byte-regexp (bytes-append (define ref-rx (cond
[(eq? ref 'head)
;; some servers report "HEAD" early, and we can
;; expect it early in the list; if that fails,
;; fall back to trying a "master" branch:
#"^HEAD|refs/heads/master$"]
[else
(byte-regexp (bytes-append
#"^refs/(?:heads|tags)/" #"^refs/(?:heads|tags)/"
(regexp-quote (string->bytes/utf-8 ref)) (regexp-quote (string->bytes/utf-8 ref))
#"$"))) #"$"))]))
(define ref-commit (define ref-commit
(or (or
;; Search list of branch and tag names: ;; Search list of branch and tag names:
@ -370,12 +422,13 @@
(and (regexp-match? ref-rx (car ref)) (and (regexp-match? ref-rx (car ref))
(cadr ref))) (cadr ref)))
;; Try matching the references as a commit/tag ID of a branch or tag: ;; Try matching the references as a commit/tag ID of a branch or tag:
(and (string? ref)
(let ([rx (id-ref->regexp ref)]) (let ([rx (id-ref->regexp ref)])
(for/or ([a-ref (in-list refs)]) (for/or ([a-ref (in-list refs)])
(and (regexp-match? rx (cadr a-ref)) (and (regexp-match? rx (cadr a-ref))
(begin (begin
(status "Commit id ~s matches ~a" ref (car a-ref)) (status "Commit id ~s matches ~a" ref (car a-ref))
(cadr a-ref))))))) (cadr a-ref))))))))
(define want-commits (define want-commits
(cond (cond
@ -385,7 +438,7 @@
[try-only-master? [try-only-master?
(status "Requested reference looks like commit id; try within master") (status "Requested reference looks like commit id; try within master")
(define-values (master-ref-commit want-commits) (define-values (master-ref-commit want-commits)
(select-commits "master" refs status #f repo)) (select-commits "master" refs '() status #f repo))
want-commits] want-commits]
[else [else
(status "Requested reference looks like commit id; getting all commits") (status "Requested reference looks like commit id; getting all commits")
@ -421,7 +474,7 @@
(write-bytes full-msg o) (write-bytes full-msg o)
(flush-output o)) (flush-output o))
;; read-pkg : input-port -> bstr-or-eof ;; read-pkt : input-port -> bstr-or-eof
;; Reads one pkt, returning eof of the special "null" pkt ;; Reads one pkt, returning eof of the special "null" pkt
(define (read-pkt i) (define (read-pkt i)
(define len-bstr (read-bytes 4 i)) (define len-bstr (read-bytes 4 i))