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

Add #:username and #:password arguments to net/git-checkout

Browse Source 
This can be used to provide authentication for accessing repositories
over HTTP(S), such as private repositories on GitHub.
This commit is contained in:
Alexis King 2016-06-20 11:37:18 -07:00 committed by Alexis King
parent 00644821de
commit d409fb5e2e
2 changed files with 47 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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"]}

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

@ -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 <dir>"
(set! tmp-dir dir)]
[("-u" "--username") username "Username used to authenticate over HTTP(S)"
(current-git-username username)]
[("-p" "--password") password "Password used to authenticate over HTTP(S)"
(current-git-password password)]
[("--quiet") "Suppress status printouts"
(set! status-printf void)]
#:args (host repo dest)