diff options
Diffstat (limited to 'guix/git.scm')
| -rw-r--r-- | guix/git.scm | 142 |
1 files changed, 81 insertions, 61 deletions
diff --git a/guix/git.scm b/guix/git.scm index 637936c16a..364b4997ae 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -20,6 +20,7 @@ (define-module (guix git) #:use-module (git) #:use-module (git object) + #:use-module (git submodule) #:use-module (guix i18n) #:use-module (guix base32) #:use-module (gcrypt hash) @@ -30,7 +31,9 @@ #:use-module (guix gexp) #:use-module (guix sets) #:use-module ((guix diagnostics) #:select (leave)) + #:use-module (guix progress) #:use-module (rnrs bytevectors) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -116,9 +119,61 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." (string-append "R:" url) url)))))) -;; Authentication appeared in Guile-Git 0.3.0, check if it is available. -(define auth-supported? - (false-if-exception (resolve-interface '(git auth)))) +(define (show-progress progress) + "Display a progress bar as we fetch Git code. PROGRESS is an +<indexer-progress> record from (git)." + (define total + (indexer-progress-total-objects progress)) + + (define hundredth + (match (quotient (indexer-progress-total-objects progress) 100) + (0 1) + (x x))) + + (define-values (done label) + (if (< (indexer-progress-received-objects progress) total) + (values (indexer-progress-received-objects progress) + (G_ "receiving objects")) + (values (indexer-progress-indexed-objects progress) + (G_ "indexing objects")))) + + (define % + (* 100. (/ done total))) + + (when (and (< % 100) (zero? (modulo done hundredth))) + (erase-current-line (current-error-port)) + (let ((width (max (- (current-terminal-columns) + (string-length label) 7) + 3))) + (format (current-error-port) "~a ~3,d% ~a" + label (inexact->exact (round %)) + (progress-bar % width))) + (force-output (current-error-port))) + + (when (= % 100.) + ;; We're done, erase the line. + (erase-current-line (current-error-port)) + (force-output (current-error-port))) + + ;; Return true to indicate that we should go on. + #t) + +(define (make-default-fetch-options) + "Return the default fetch options." + (let ((auth-method (%make-auth-ssh-agent))) + ;; The #:transfer-progress and #:proxy-url options appeared in Guile-Git + ;; 0.4.0. Omit them when using an older version. + (catch 'wrong-number-of-args + (lambda () + (make-fetch-options auth-method + ;; Guile-Git doesn't distinguish between these. + #:proxy-url (or (getenv "http_proxy") + (getenv "https_proxy")) + #:transfer-progress + (and (isatty? (current-error-port)) + show-progress))) + (lambda args + (make-fetch-options auth-method))))) (define (clone* url directory) "Clone git repository at URL into DIRECTORY. Upon failure, @@ -127,18 +182,10 @@ make sure no empty directory is left behind." (lambda () (mkdir-p directory) - ;; Note: Explicitly pass options to work around the invalid default - ;; value in Guile-Git: <https://bugs.gnu.org/29238>. - (if (module-defined? (resolve-interface '(git)) - 'clone-init-options) - (let ((auth-method (and auth-supported? - (%make-auth-ssh-agent)))) - (clone url directory - (if auth-supported? - (make-clone-options - #:fetch-options (make-fetch-options auth-method)) - (clone-init-options)))) - (clone url directory))) + (let ((auth-method (%make-auth-ssh-agent))) + (clone url directory + (make-clone-options + #:fetch-options (make-default-fetch-options))))) (lambda _ (false-if-exception (rmdir directory))))) @@ -167,12 +214,7 @@ corresponding Git object." ;; read out-of-bounds when passed a string shorter than 40 chars, ;; which is why we delay calls to it below. (if (< len 40) - (if (module-defined? (resolve-interface '(git object)) - 'object-lookup-prefix) - (object-lookup-prefix repository (string->oid commit) len) - (raise (condition - (&message - (message "long Git object ID is required"))))) + (object-lookup-prefix repository (string->oid commit) len) (object-lookup repository (string->oid commit))))) (('tag-or-commit . str) (if (or (> (string-length str) 40) @@ -234,40 +276,23 @@ dynamic extent of EXP." (lambda (key err) (report-git-error err)))) -(define (load-git-submodules) - "Attempt to load (git submodules), which was missing until Guile-Git 0.2.0. -Return true on success, false on failure." - (match (false-if-exception (resolve-interface '(git submodule))) - (#f - (set! load-git-submodules (const #f)) - #f) - (iface - (module-use! (resolve-module '(guix git)) iface) - (set! load-git-submodules (const #t)) - #t))) - (define* (update-submodules repository #:key (log-port (current-error-port))) "Update the submodules of REPOSITORY, a Git repository object." - ;; Guile-Git < 0.2.0 did not have (git submodule). - (if (load-git-submodules) - (for-each (lambda (name) - (let ((submodule (submodule-lookup repository name))) - (format log-port (G_ "updating submodule '~a'...~%") - name) - (submodule-update submodule) - - ;; Recurse in SUBMODULE. - (let ((directory (string-append - (repository-working-directory repository) - "/" (submodule-path submodule)))) - (with-repository directory repository - (update-submodules repository - #:log-port log-port))))) - (repository-submodules repository)) - (format (current-error-port) - (G_ "Support for submodules is missing; \ -please upgrade Guile-Git.~%")))) + (for-each (lambda (name) + (let ((submodule (submodule-lookup repository name))) + (format log-port (G_ "updating submodule '~a'...~%") + name) + (submodule-update submodule) + + ;; Recurse in SUBMODULE. + (let ((directory (string-append + (repository-working-directory repository) + "/" (submodule-path submodule)))) + (with-repository directory repository + (update-submodules repository + #:log-port log-port))))) + (repository-submodules repository))) (define-syntax-rule (false-if-git-not-found exp) "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised." @@ -331,12 +356,9 @@ it unchanged." ;; Only fetch remote if it has not been cloned just before. (when (and cache-exists? (not (reference-available? repository ref))) - (if auth-supported? - (let ((auth-method (and auth-supported? - (%make-auth-ssh-agent)))) - (remote-fetch (remote-lookup repository "origin") - #:fetch-options (make-fetch-options auth-method))) - (remote-fetch (remote-lookup repository "origin")))) + (let ((auth-method (%make-auth-ssh-agent))) + (remote-fetch (remote-lookup repository "origin") + #:fetch-options (make-default-fetch-options)))) (when recursive? (update-submodules repository #:log-port log-port)) @@ -359,9 +381,7 @@ it unchanged." ;; Reclaim file descriptors and memory mappings associated with ;; REPOSITORY as soon as possible. - (when (module-defined? (resolve-interface '(git repository)) - 'repository-close!) - (repository-close! repository)) + (repository-close! repository) (values cache-directory (oid->string oid) relation))))) |