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) (or (current-pkg-network-retries)
(read-pkg-cfg/def '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) (define (read-pkg-cfg/def k)
;; Lock is held for the current scope, but if ;; Lock is held for the current scope, but if
;; the key is not found in the current scope, ;; the key is not found in the current scope,

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

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

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

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