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

Merge pull request #1472 from lexi-lambda/pkg-git-credentials

Browse Source 
Add support for git-backed packages that require authentication
This commit is contained in:
Alexis King 2016-10-06 18:24:24 -07:00 committed by GitHub
commit d9750064b9
13 changed files with 347 additions and 102 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

@ -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,27 @@ 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.}
#:changed "6.6.0.5" @elem{Changed to raise @racket[exn:fail:git] exceptions
instead of @racket[exn:fail].}]}
@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"]}
@defstruct[(exn:fail:git exn:fail) () #:transparent]{
Raised by @racket[git-checkout] due to errors parsing or communicating with the git protocol.
@history[#:added "6.6.0.5"]}

7
pkgs/racket-doc/pkg/scribblings/pkg.scrbl
View File

@ -944,6 +944,10 @@ for @nonterm{key}.
documentation; an empty string, which is the default, disables
the URL so that the local filesystem is used. This key can be
set only in @exec{installation} scope.}
@item{@exec{git-checkout-credentials} --- A list of git credentials in the form
@nonterm{username}@litchar{:}@nonterm{password} that are tried when downloading
packages with git sources using the HTTP or HTTPS protocols. The credentials are
currently stored @bold{unencrypted} on the filesystem.}
@item{@exec{trash-max-packages} --- A limit on the number of package implementations
that are kept in a trash folder when the package is removed or updated.}
@item{@exec{trash-max-seconds} --- A limit on the time since a package is removed or
@ -955,7 +959,8 @@ for @nonterm{key}.
]
@history[#:changed "6.1.1.6" @elem{Added @exec{trash-max-packages} and @exec{trash-max-seconds}.}
#:changed "6.3" @elem{Added @exec{network-retries}.}]}
#:changed "6.3" @elem{Added @exec{network-retries}.}
#:changed "6.6.0.5" @elem{Added @exec{git-checkout-credentials}.}]}
@subcommand{@command/toc{catalog-show} @nonterm{option} ... @nonterm{package-name} ...

82
pkgs/racket-test/tests/pkg/git-http-proxy.rkt Normal file
View File

@ -0,0 +1,82 @@
#lang racket/base
(provide serve-git-http-proxy!)
(require net/base64
net/uri-codec
net/url
racket/match
racket/port
racket/runtime-path
racket/string
racket/system
web-server/http
web-server/servlet-env)
(define (url-path-string url)
(string-join (map path/param-path (url-path url))
"/" #:before-first "/"))
(define (url-query-string url)
(alist->form-urlencoded (url-query url)))
(define (verify-authorization header-value)
; strip #"Basic " off of the header value
(define encoded-value (subbytes header-value 6))
(equal? (string-split (bytes->string/utf-8 (base64-decode encoded-value)) ":")
'("user" "password")))
(define (serve-git-http-proxy req)
; check if the right Authorization header is provided
(define authorization (headers-assq* #"Authorization" (request-headers/raw req)))
(cond
[(and authorization (verify-authorization (header-value authorization)))
(parameterize ([current-environment-variables (environment-variables-copy
(current-environment-variables))])
; git-http-backend depends on these environment variables to find the git repo
(putenv "GIT_PROJECT_ROOT" (path->string (find-system-path 'temp-dir)))
(putenv "GIT_HTTP_EXPORT_ALL" "")
; set standard CGI environment variables
(environment-variables-set! (current-environment-variables)
#"REQUEST_METHOD" (request-method req))
(putenv "PATH_INFO" (url-path-string (request-uri req)))
(putenv "QUERY_STRING" (url-query-string (request-uri req)))
(let ([content-type (headers-assq* #"Content-Type" (request-headers/raw req))])
(when content-type
(environment-variables-set! (current-environment-variables)
#"CONTENT_TYPE" (header-value content-type))))
; run git-http-backend
(match-define (list git-response-port git-body-port _ _ _)
(process*/ports #f #f (current-error-port)
(find-executable-path "git") "http-backend"))
; pass POST body to git-http-backend
(when (request-post-data/raw req)
(write-bytes (request-post-data/raw req) git-body-port))
(close-output-port git-body-port)
; convert CGI headers to ones the web server can understand
(define headers
(for/list ([line (in-lines git-response-port)]
#:break (zero? (string-length line)))
(apply header (map string->bytes/utf-8 (string-split line ": ")))))
; produce a response
(response 200 #"OK" (current-seconds) #f headers
(λ (out)
(copy-port git-response-port out)
(close-input-port git-response-port))))]
; if authorization fails, return a WWW-Authenticate header
[else (response/full 401 #"Authorization Required" (current-seconds)
#"text/plain; charset=utf-8"
(list (header #"WWW-Authenticate" #"Basic"))
(list #"Repository not found."))]))
(define (serve-git-http-proxy! #:port port)
(serve/servlet serve-git-http-proxy
#:port port
#:command-line? #t
#:servlet-regexp #rx""))

3
pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang info
(define collection 'multi)

1
pkgs/racket-test/tests/pkg/tests-catalogs.rkt
View File

@ -14,6 +14,7 @@
(initialize-catalogs)
$ "raco pkg config --set catalogs http://localhost:9990"
$ "raco pkg config --set git-checkout-credentials user:password"
$ "racket -l racket/base -l pkg/lib -e '(pkg-config-catalogs)'"
=stdout> "'(\"http://localhost:9990\")\n"

12
pkgs/racket-test/tests/pkg/tests-install.rkt
View File

@ -251,4 +251,14 @@
$ "racket -e '(require pkg/lib)' -e '(path->pkg (build-path (pkg-directory \"pkg-test1\") \"pkg-test2\"))'"
=stdout> "\"pkg-test1\"\n"
$ "raco pkg remove pkg-test2-snd pkg-test1"
$ "racket -e '(require pkg-test1)'" =exit> 1)))))
$ "racket -e '(require pkg-test1)'" =exit> 1))
(with-fake-root
(shelly-case
"git package that requires authentication"
$ "raco pkg config --set catalogs http://localhost:9990"
$ "raco pkg install pkg-git" =exit> 1
$ "raco pkg config --set git-checkout-credentials user:bad-password"
$ "raco pkg install pkg-git" =exit> 1
$ "raco pkg config --set git-checkout-credentials user:password"
$ "raco pkg install pkg-git")))))

34
pkgs/racket-test/tests/pkg/util.rkt
View File

@ -10,8 +10,10 @@
racket/list
racket/format
racket/port
racket/string
setup/dirs
"shelly.rkt")
"shelly.rkt"
"git-http-proxy.rkt")
(define-runtime-path test-source-directory ".")
@ -167,8 +169,11 @@
(with-thread
(λ () (start-pkg-server *index-ht-2* 9991))
(λ ()
(with-thread (λ () (start-file-server))
t)))))]))
(with-thread
(λ () (start-file-server))
(λ ()
(with-thread (λ () (serve-git-http-proxy! #:port 9996))
t)))))))]))
(define-syntax-rule (with-servers e ...)
(with-servers* (λ () e ...)))
@ -246,7 +251,28 @@
'source
"http://localhost:9997/pkg-test2.zip"
'dependencies
'("pkg-test1"))))
'("pkg-test1")))
(initialize-catalogs/git))
(define (initialize-catalogs/git)
(define pkg-git.git (make-temporary-file "pkg-git-~a.git"))
(delete-file pkg-git.git)
(parameterize ([current-directory (build-path test-source-directory "test-pkgs")])
(copy-directory/files (build-path test-source-directory "test-pkgs" "pkg-git") pkg-git.git))
(define checksum
(parameterize ([current-directory pkg-git.git])
(system "git init")
(system "git add -A")
(system "git commit -m 'initial commit'")
(string-trim
(with-output-to-string
(λ () (system "git rev-parse HEAD"))))))
(match-define-values [_ pkg-git.git-filename _] (split-path pkg-git.git))
(hash-set! *index-ht-1* "pkg-git"
(hasheq 'checksum checksum
'source (~a "http://localhost:9996/" (path->string pkg-git.git-filename)))))
(define (set-file path content)
(make-parent-directory* path)

156
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,22 @@
;; 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
(struct-out exn:fail:git))
(define-logger git-checkout)
(define current-git-username (make-parameter #f))
(define current-git-password (make-parameter #f))
(struct exn:fail:git exn:fail () #:transparent)
(define (raise-git-error name fmt . vals)
(raise (exn:fail:git (apply format (string-append "~s: " fmt) name vals)
(current-continuation-marks))))
;; Like `git clone`, but producing just the checkout
(define (git-checkout host
repo
@ -35,7 +48,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 +66,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
@ -66,7 +81,7 @@
;; smart protocol provides packets:
(read-pkts i)))
(unless (pair? pkts)
(error 'git-checkout "no initial pkts from the server"))
(raise-git-error 'git-checkout "no initial pkts from the server"))
;; Parse server's initial reply
(define server-capabilities (parse-server-capabilities (car pkts)))
@ -106,7 +121,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.
@ -120,12 +135,12 @@
[(regexp-match? #rx"^shallow " r)
(loop)]
[else
(error 'git-checkout "expected shallow, got ~s" r)])))
(raise-git-error 'git-checkout "expected shallow, got ~s" r)])))
;; Tell the server that we're ready for the objects
(define nak (read-pkt i))
(unless (equal? #"NAK\n" nak)
(error 'git-checkout "expected NAK, got ~s" nak)))
(raise-git-error 'git-checkout "expected NAK, got ~s" nak)))
(make-directory* tmp-dir)
(define tmp (make-tmp-info tmp-dir #:fresh? #t))
@ -189,18 +204,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 +232,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
@ -224,16 +244,16 @@
"application/x-git-upload-pack-advertisement")
;; "smart" protocol
(unless (regexp-match-peek #px#"^[0-9a-f]{4}#" i)
(error 'git-checkout (~a "error reading repository content;\n"
" response is not consistent with the Git protocol\n"
" initial portion: ~s")
(read-bytes 640 i)))
(raise-git-error 'git-checkout (~a "error reading repository content;\n"
" response is not consistent with the Git protocol\n"
" initial portion: ~s")
(read-bytes 640 i)))
(define pkt (read-pkt i))
(define term-pkt (read-pkt i))
(unless (eof-object? term-pkt)
(error 'git-checkout (~a "expected a null packet, received something else\n"
" packet: ~s")
term-pkt))
(raise-git-error 'git-checkout (~a "expected a null packet, received something else\n"
" packet: ~s")
term-pkt))
#f]
[else
;; "dumb" protocol
@ -243,7 +263,7 @@
(lambda ()
(unless ok? (close-input-port i))))]
[else
(error 'git-checkout "unrecognized transport\n given: ~e" transport)]))
(raise-git-error 'git-checkout "unrecognized transport\n given: ~e" transport)]))
;; want-step: transport-sym string natural string input-port output-port
;; -> (values input-port output-port)
@ -256,12 +276,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 +294,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))]))
@ -305,8 +325,7 @@
(define m (regexp-match #px#"^([0-9a-fA-F]{40})[ \t]([^\0\n]+)[\0\n]" pkt))
(unless m
(when initial-error (initial-error))
(error 'git-checkout "could not parse ref pkt\n pkt: ~s"
pkt))
(raise-git-error 'git-checkout "could not parse ref pkt\n pkt: ~s" pkt))
(define name (caddr m))
(define id (bytes->string/utf-8 (cadr m)))
(cond
@ -351,7 +370,7 @@
(for/list ([ref (in-list refs)])
(cadr ref))]
[else
(error 'git "could not find requested reference\n reference: ~a" ref)]))
(raise-git-error 'git "could not find requested reference\n reference: ~a" ref)]))
(values ref-commit want-commits))
@ -389,16 +408,16 @@
[else
(unless (and (bytes? len-bstr)
(= 4 (bytes-length len-bstr)))
(error 'git-checkout "error getting pkt length"))
(raise-git-error 'git-checkout "error getting pkt length"))
(define len (string->number (bytes->string/utf-8 len-bstr #\?) 16))
(unless len
(error 'git-checkout "error getting pkt length\n length string: ~e" len-bstr))
(raise-git-error 'git-checkout "error getting pkt length\n length string: ~e" len-bstr))
(cond
[(= len 0) eof] ; flush pkt
[else
(define payload-len (- len 4))
(unless (payload-len . >= . 0)
(error 'git-checkout "pkt length makes no sense\n length: ~a" len))
(raise-git-error 'git-checkout "pkt length makes no sense\n length: ~a" len))
(read-bytes-exactly 'payload payload-len i)])]))
;; read a list of pkts until an empty packet is found
@ -427,10 +446,10 @@
(when (and (eof-object? pack-bstr)
initial-eof-handler)
(initial-eof-handler))
(error 'git-checkout "header error\n bytes: ~s" pack-bstr))
(raise-git-error 'git-checkout "header error\n bytes: ~s" pack-bstr))
(define vers (read-bytes 4 i))
(unless (equal? vers #"\0\0\0\2")
(error 'git-checkout "only version 2 supported"))
(raise-git-error 'git-checkout "only version 2 supported"))
(define count-bstr (read-bytes-exactly 'count 4 i))
(define count (integer-bytes->integer count-bstr #t #t))
(define obj-stream-poses (make-hash)) ; for OBJ_OFS_DELTA references
@ -458,7 +477,7 @@
(define obj-stream-pos (file-position i))
(define c (read-byte-only 'type-and-size i))
(define type (bitwise-and (arithmetic-shift c -4) #x7))
(when (zero? type) (error 'git-checkout "bad packfile type"))
(when (zero? type) (raise-git-error 'git-checkout "bad packfile type"))
(define init-len (bitwise-and c #xF))
(define len
(if (msb-set? c)
@ -472,7 +491,7 @@
[(ofs-delta)
(define delta (read-offset-integer i))
(hash-ref obj-stream-poses (- obj-stream-pos delta)
(lambda () (error 'git-checkout "OBJ_OFS_DELTA object not found")))]
(lambda () (raise-git-error 'git-checkout "OBJ_OFS_DELTA object not found")))]
[else #f]))
(define obj
(save-object (lambda (o) (zlib-inflate i o)) len type-sym type-info tmp))
@ -592,9 +611,9 @@
(cond
[(= 1 (length matches)) (car matches)]
[(null? matches)
(error 'git-checkout "no commit found matching id: ~a" ref)]
(raise-git-error 'git-checkout "no commit found matching id: ~a" ref)]
[else
(error 'git-checkout "found multiple commits matching id: ~a" ref)]))
(raise-git-error 'git-checkout "found multiple commits matching id: ~a" ref)]))
(define (id-ref->regexp ref)
(regexp (~a "^" (regexp-quote (string-downcase ref)))))
@ -624,17 +643,17 @@
(lambda (i)
(define m (regexp-try-match #px"^object ([0-9a-fA-F]{40})" i))
(unless m
(error 'git-checkout "cannot extract commit from tag file for ~s"
(bytes->hex-string obj-id)))
(raise-git-error 'git-checkout "cannot extract commit from tag file for ~s"
(bytes->hex-string obj-id)))
(cadr m))))
(define commit-id (hex-string->bytes (bytes->string/utf-8 commit-id-bstr)))
(extract-commit-tree commit-id obj-ids tmp dest-dir strict-links?)]
[(tree)
(extract-tree obj-id obj-ids tmp dest-dir strict-links?)]
[else
(error 'git-checkout "cannot extract tree from ~a: ~s"
(object-type obj)
(bytes->hex-string obj-id))]))
(raise-git-error 'git-checkout "cannot extract tree from ~a: ~s"
(object-type obj)
(bytes->hex-string obj-id))]))
;; extract-commit-info: input-port bytes -> string (listof string)
;; Returns the commit's tree and parent ids.
@ -642,11 +661,11 @@
(define (extract-commit-info i obj-id)
(define m (regexp-try-match #px"^tree ([0-9a-fA-F]{40})" i))
(unless m
(error 'git-checkout
(~a "cannot extract tree from commit file for ~s\n"
" content starts: ~s")
(bytes->hex-string obj-id)
(peek-bytes 64 0 i)))
(raise-git-error 'git-checkout
(~a "cannot extract tree from commit file for ~s\n"
" content starts: ~s")
(bytes->hex-string obj-id)
(peek-bytes 64 0 i)))
(values
;; tree id string:
(bytes->string/utf-8 (cadr m))
@ -693,7 +712,7 @@
;; submodule; just make a directory placeholder
(make-directory* (build-path dest-dir fn))]
[else
(error 'extract-tree "unknown mode: ~s" mode)])
(raise-git-error 'extract-tree "unknown mode: ~s" mode)])
(loop))))))
;; extract-tree-entry: input-port -> bytes-or-#f bytes-or-#f path-or-#f
@ -758,7 +777,7 @@
(for/list ([l (in-lines i)]
#:unless (equal? l ""))
(define m (regexp-match #rx"^P (.*)" l))
(unless m (error 'git-checkout "error parsing packfile list line\n line: ~e" l))
(unless m (raise-git-error 'git-checkout "error parsing packfile list line\n line: ~e" l))
(cadr m)))
;; read-dumb-packfile : string (hashof string object) tmp conn strung status
@ -818,7 +837,7 @@
;; Parse the object description:
(define header-m (regexp-try-match #rx#"^[^\0]*\0" i))
(unless header-m
(error 'git-checkout "bad initial line for object content"))
(raise-git-error 'git-checkout "bad initial line for object content"))
(define header (car header-m))
(define header-len (bytes-length header))
(define type-sym (string->symbol
@ -827,7 +846,7 @@
(bytes->string/utf-8 (cadr (or (regexp-match #rx"[^ ]* ([0-9]+)" header)
'(#"" #""))))))
(unless (memq type-sym valid-types)
(error 'git-checkout "bad type: ~e" type-sym))
(raise-git-error 'git-checkout "bad type: ~e" type-sym))
(define obj
(save-object (lambda (o) (copy-port i o))
@ -882,9 +901,9 @@
(define status (let ([m (regexp-match #rx"^[^ ]* ([0-9]+)" status-line)])
(and m (string->number (bytes->string/utf-8 (cadr m))))))
(unless (memv status '(200))
(error 'git-checkout "~a\n server respone: ~a"
msg
status-line)))
(raise-git-error 'git-checkout "~a\n server respone: ~a"
msg
status-line)))
;; ----------------------------------------
;; Temporary directory & database
@ -914,9 +933,9 @@
(define (call-with-output-object tmp filename len proc)
(define (check-len got-len)
(unless (= len got-len)
(error 'git-checkout "size mismatch\n expected: ~a\n received: ~a"
len
got-len)))
(raise-git-error 'git-checkout "size mismatch\n expected: ~a\n received: ~a"
len
got-len)))
(cond
[(len . < . 256)
(define location (tmp-info-pos tmp))
@ -981,21 +1000,20 @@
(define bstr (read-bytes len i))
(unless (and (bytes? bstr)
(= (bytes-length bstr) len))
(error 'git-checkout (~a "error getting bytes for ~a\n"
" expected length: ~a\n"
" got length: ~a")
what
len
(if (eof-object? bstr)
eof
(bytes-length bstr))))
(raise-git-error 'git-checkout (~a "error getting bytes for ~a\n"
" expected length: ~a\n"
" got length: ~a")
what
len
(if (eof-object? bstr)
eof
(bytes-length bstr))))
bstr)
(define (read-byte-only what i)
(define c (read-byte i))
(unless (byte? c)
(error 'git-checkout "expected to get a byte for ~a, got enf-of-file"
what))
(raise-git-error 'git-checkout "expected to get a byte for ~a, got enf-of-file" what))
c)
;; copy-port-n : input-port output-port natural -> void
@ -1005,7 +1023,7 @@
(define bstr (read-bytes n i))
(unless (and (bytes? bstr)
(= (bytes-length bstr) n))
(error 'git-checkout "not enough bytes during copy"))
(raise-git-error 'git-checkout "not enough bytes during copy"))
(write-bytes bstr o)]
[else
(copy-port-n i o 4096)
@ -1068,7 +1086,7 @@
(define cmf (read-byte-only 'zlib-cmf i))
(define flg (read-byte-only 'zlib-flag i))
(unless (= 8 (bitwise-and cmf #xF))
(error 'git-checkout "compression is not `deflate`"))
(raise-git-error 'git-checkout "compression is not `deflate`"))
(when (bitwise-bit-set? flg 5)
;; read dictid
(read-bytes-exactly 'dictid 4 i))
@ -1109,6 +1127,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)

24
racket/collects/pkg/private/checkout-credentials.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket/base
(require net/git-checkout
racket/list
"config.rkt")
(provide call-with-git-checkout-credentials)
(define (call-with-git-checkout-credentials thunk)
(let loop ([credentials-list (cons #f (get-git-checkout-credentials))])
(define credentials (first credentials-list))
(with-handlers ([exn:fail:git? (λ (exn)
(if (empty? (rest credentials-list))
(raise exn)
(loop (rest credentials-list))))])
(define c (make-custodian))
(parameterize ([current-custodian c]
[current-git-username (and credentials (hash-ref credentials 'username))]
[current-git-password (and credentials (hash-ref credentials 'password))])
(dynamic-wind
void
thunk
(lambda ()
(custodian-shutdown-all c)))))))

39
racket/collects/pkg/private/config.rkt
View File

@ -4,6 +4,7 @@
racket/path
racket/match
racket/format
racket/string
net/url
"../path.rkt"
"dirs.rkt"
@ -37,6 +38,10 @@
(or (current-pkg-network-retries)
(read-pkg-cfg/def 'network-retries)))
(define (get-git-checkout-credentials)
(or (current-pkg-git-checkout-credentials)
(read-pkg-cfg/def 'git-checkout-credentials)))
(define (read-pkg-cfg/def k)
;; Lock is held for the current scope, but if
;; the key is not found in the current scope,
@ -56,6 +61,7 @@
['trash-max-packages 512]
['trash-max-seconds (* 60 60 24 2)] ; 2 days
['network-retries 5]
['git-checkout-credentials '()]
[_ #f]))
(define c (read-pkg-file-hash (pkg-config-file)))
(define v (hash-ref c k 'none))
@ -197,6 +203,35 @@
" current package scope: ~a")
(current-pkg-scope)))
(update-pkg-cfg! 'doc-open-url (if (equal? val "") #f val))]
[(list* "git-checkout-credentials" vals)
(define (credentials-format-error msg val)
(pkg-error (~a msg "\n"
" given: ~a\n"
" expected: value in the form <username>:<password>")
val))
(update-pkg-cfg! 'git-checkout-credentials
(for/list ([val (in-list vals)])
(match (string-split val ":" #:trim? #f)
[(list "" _)
(credentials-format-error
"invalid empty username in git checkout credentials"
val)]
[(list _ "")
(credentials-format-error
"invalid empty password in git checkout credentials"
val)]
[(list username password)
`#hasheq((username . ,username)
(password . ,password))]
[(list* _ _ _)
(credentials-format-error
"too many elements for git checkout credentials"
val)]
[(list _)
(credentials-format-error
"not enough elements for git checkout credentials"
val)])))
(displayln "WARNING: checkout credentials are stored UNENCRYPTED" (current-error-port))]
[(list* key args)
(pkg-error "unsupported config key\n key: ~a" key)])]
[else
@ -220,6 +255,9 @@
(printf "~a~a\n" indent (read-pkg-cfg/def (string->symbol key)))]
["doc-open-url"
(printf "~a~a\n" indent (or (read-pkg-cfg/def 'doc-open-url) ""))]
["git-checkout-credentials"
(for ([creds (in-list (read-pkg-cfg/def 'git-checkout-credentials))])
(printf "~a~a:~a\n" indent (hash-ref creds 'username) (hash-ref creds 'password)))]
[_
(pkg-error "unsupported config key\n key: ~e" key)])]
[(list)
@ -237,6 +275,7 @@
"download-cache-dir"
"download-cache-max-files"
"download-cache-max-bytes"
"git-checkout-credentials"
"trash-max-packages"
"trash-max-seconds"
"network-retries"))])

26
racket/collects/pkg/private/download.rkt
View File

@ -11,6 +11,7 @@
"path.rkt"
"print.rkt"
"config.rkt"
"checkout-credentials.rkt"
"network.rkt")
(provide download-file!
@ -101,18 +102,21 @@
(define (download!)
(when download-printf
(download-printf "Downloading repository ~a\n" (url->string url)))
(call-with-network-retries
(call-with-git-checkout-credentials
(lambda ()
(git-checkout host #:port port repo
#:dest-dir dest-dir
#:ref checksum
#:status-printf (lambda (fmt . args)
(define (strip-ending-newline s)
(regexp-replace #rx"\n$" s ""))
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
#:transport transport
#:strict-links? #t
#:depth 1)))
(call-with-network-retries
(lambda ()
(git-checkout host #:port port repo
#:dest-dir dest-dir
#:ref checksum
#:status-printf (lambda (fmt . args)
(define (strip-ending-newline s)
(regexp-replace #rx"\n$" s ""))
(log-pkg-debug (strip-ending-newline
(apply format fmt args))))
#:transport transport
#:strict-links? #t
#:depth 1)))))
(set! unpacked? #t)
;; package directory as ".tgz" so it can be cached:
(parameterize ([current-directory dest-dir])

3
racket/collects/pkg/private/params.rkt
View File

@ -34,3 +34,6 @@
(define current-pkg-network-retries
(make-parameter #f))
(define current-pkg-git-checkout-credentials
(make-parameter #f))

35
racket/collects/pkg/private/stage.rkt
View File

@ -31,6 +31,7 @@
"orig-pkg.rkt"
"git.rkt"
"prefetch.rkt"
"checkout-credentials.rkt"
"network.rkt")
(provide (struct-out install-info)
@ -735,23 +736,25 @@
(define-values (transport host port repo branch path)
(split-git-or-hub-url pkg-url #:type type))
(download-printf "Querying Git references for ~a at ~a\n" pkg-name pkg-url-str)
(call-with-network-retries
(call-with-git-checkout-credentials
(lambda ()
;; Supplying `#:dest-dir #f` means that we just resolve `branch`
;; to an ID:
(git-checkout host #:port port repo
#:dest-dir #f
#:ref branch
#:status-printf (lambda (fmt . args)
(define (strip-ending-newline s)
(regexp-replace #rx"\n$" s ""))
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
#:initial-error (lambda ()
(pkg-error (~a "Git checkout initial protocol failed;\n"
" the given URL might not refer to a Git repository\n"
" given URL: ~a")
pkg-url-str))
#:transport transport)))]
(call-with-network-retries
(lambda ()
;; Supplying `#:dest-dir #f` means that we just resolve `branch`
;; to an ID:
(git-checkout host #:port port repo
#:dest-dir #f
#:ref branch
#:status-printf (lambda (fmt . args)
(define (strip-ending-newline s)
(regexp-replace #rx"\n$" s ""))
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
#:initial-error (lambda ()
(pkg-error (~a "Git checkout initial protocol failed;\n"
" the given URL might not refer to a Git repository\n"
" given URL: ~a")
pkg-url-str))
#:transport transport)))))]
[(github)
(match-define (list* user repo branch path)
(split-github-url pkg-url))