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

Make raco pkg try git-checkout-credentials when cloning a repository

Browse Source
This commit is contained in:
Alexis King 2016-09-29 12:57:19 -07:00
parent afa17a3df6
commit 6d63e4443f
5 changed files with 65 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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)))))))

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

@ -38,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,

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))