diff --git a/pkgs/net-doc/net/scribblings/git-checkout.scrbl b/pkgs/net-doc/net/scribblings/git-checkout.scrbl index 46cecaff20..2d22a6fe9c 100644 --- a/pkgs/net-doc/net/scribblings/git-checkout.scrbl +++ b/pkgs/net-doc/net/scribblings/git-checkout.scrbl @@ -36,7 +36,9 @@ for information on command-line arguments and flags. [(git) 9418] [(http) 80] [(https) 443])] - [#:strict-links? strict-links? any/c #f]) + [#:strict-links? strict-links? any/c #f] + [#:username username (or/c string? #f) (current-git-username)] + [#:password password (or/c string? #f) (current-git-password)]) string?]{ Contacts the server at @racket[hostname] and @racket[port] @@ -96,6 +98,20 @@ If @racket[strict-links?] is true, then the checkout fails with an error if it would produce a symbolic link that refers to an absolute path or to a relative path that contains up-directory elements. +If both @racket[username] and @racket[password] are non-@racket[#f] +@emph{and} @racket[transport] is @racket['http] or @racket['https], then +the provided credentials are passed to the remote server using HTTP Basic +Authentication. + @history[#:added "6.1.1.1" #:changed "6.3" @elem{Added the @racket[initial-error] argument.} - #: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.}]} + +@deftogether[(@defparam[current-git-username username (or/c string? #f)] + @defparam[current-git-password password (or/c string? #f)])]{ +Parameters used by @racket[git-checkout] as the default values of the +@racket[_username] and @racket[_password] arguments to control +authentication with the remote server. + +@history[#:added "6.6.0.5"]} diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt index 00dd2b1b50..684fd13272 100644 --- a/racket/collects/net/git-checkout.rkt +++ b/racket/collects/net/git-checkout.rkt @@ -7,6 +7,7 @@ file/gunzip file/private/check-path openssl/sha1 + net/base64 net/url net/head net/http-client @@ -16,10 +17,15 @@ ;; http://stefan.saasen.me/articles/git-clone-in-haskell-from-the-bottom-up/ ;; provided many helpful hints for this implementation. -(provide git-checkout) +(provide git-checkout + current-git-username + current-git-password) (define-logger git-checkout) +(define current-git-username (make-parameter #f)) +(define current-git-password (make-parameter #f)) + ;; Like `git clone`, but producing just the checkout (define (git-checkout host repo @@ -35,7 +41,9 @@ #:clean-tmp-dir? [clean-tmp-dir? (not given-tmp-dir)] #:verify-server? [verify? #t] #:port [given-port #f] - #:strict-links? [strict-links? #f]) + #:strict-links? [strict-links? #f] + #:username [username (current-git-username)] + #:password [password (current-git-password)]) (let retry-loop ([given-depth given-depth]) (define tmp-dir (or given-tmp-dir (make-temporary-file "git~a" 'directory))) @@ -51,7 +59,7 @@ (status "Contacting ~a" host) (define-values (i o dumb-protocol?) - (initial-connect transport host verify? port repo status)) + (initial-connect transport host verify? port repo status username password)) ((let/ec esc (dynamic-wind void @@ -106,7 +114,7 @@ ;; Tell the server that we're ready for the objects (write-pkt o "done\n") - (set!-values (i o) (done-step transport host verify? port repo i o)) + (set!-values (i o) (done-step transport host verify? port repo username password i o)) (when depth ;; If we wrote `deepen`, then the server replies with `shallow`s. @@ -189,18 +197,23 @@ ;; ---------------------------------------- ;; Transports: git, http, and https -(define http-request-headers +(define (http-request-headers username password) ;; bitbucket.org seems to require a "git" value for "User-Agent", ;; otherwise it returns a "broken link" web page - '("User-Agent: git/1.9")) + (define base-headers '("User-Agent: git/1.9")) + ;; include an Authorization header if credentials are provided + (if (and username password) + (cons (~a "Authorization: Basic " (base64-encode (string->bytes/utf-8 (~a username ":" password)) #"")) + base-headers) + base-headers)) -;; initial-connect: transport-sym string bool natural string status-proc +;; initial-connect: transport-sym string bool natural string status-proc string string ;; -> (values input-port output-port boolean) ;; Contacts the server and returns an output port for writing ;; the request (ignored if not needed for the the transport) ;; and an input port from reading the available references. The ;; boolean result indicates whether the protocol is "dumb". -(define (initial-connect transport host verify? port repo status) +(define (initial-connect transport host verify? port repo status username password) (case transport [(git) (define-values (i o) (tcp-or-tunnel-connect "git" host port)) @@ -212,7 +225,7 @@ (define-values (i headers) (parameterize ([current-https-protocol (ssl-context verify?)]) (get-pure-port/headers (string->url url-str) - http-request-headers + (http-request-headers username password) #:redirections 5))) (define ok? #f) (dynamic-wind @@ -256,12 +269,12 @@ (close-input-port i) (values (open-input-bytes #"") (open-output-bytes))])) -;; done-step: transport-sym string bool natural string input-port output-port +;; done-step: transport-sym string bool natural string string string input-port output-port ;; -> (values input-port output-port) ;; Replaces the connection, if appropriate to the transport, after ;; writing the wanted references and before reading the server's ;; response. -(define (done-step transport host verify? port repo i o) +(define (done-step transport host verify? port repo username password i o) (case transport [(git) (values i o)] [(http https) @@ -274,7 +287,7 @@ "/git-upload-pack")) s (append - http-request-headers + (http-request-headers username password) (list "Content-Type: application/x-git-upload-pack-request"))))) (values i (open-output-nowhere))])) @@ -1109,6 +1122,10 @@ (set! ref branch/tag/commit)] [("--tmp") dir "Write temporary files to