summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-10-12 22:33:05 +0200
committerLudovic Courtès <ludo@gnu.org>2020-10-22 17:10:25 +0200
commit298f9d29d6c26e408a90d08d147d926aa6f81ab3 (patch)
tree69da018ebe34a7639a27611dc12f7946b0f3f541 /guix
parent59bb1ae3a9aeae75a75b20090253613a7a8800d8 (diff)
git: Display a progress bar while fetching a repo.
Fixes <https://bugs.gnu.org/39260>. This uses the API of the yet-to-be-released Guile-Git 0.4.0. Using an older version is still possible, but progress report is disabled. * guix/git.scm (show-progress, make-default-fetch-options): New procedures. (clone*, update-cached-checkout): Use it instead of 'make-fetch-options'.
Diffstat (limited to 'guix')
-rw-r--r--guix/git.scm59
1 files changed, 57 insertions, 2 deletions
diff --git a/guix/git.scm b/guix/git.scm
index cfb8d626f5..b81a011443 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -31,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)
@@ -117,6 +119,59 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
(string-append "R:" url)
url))))))
+(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 option appeared in Guile-Git 0.4.0. Omit it
+ ;; when using an older version.
+ (catch 'wrong-number-of-args
+ (lambda ()
+ (make-fetch-options auth-method
+ #: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,
make sure no empty directory is left behind."
@@ -127,7 +182,7 @@ make sure no empty directory is left behind."
(let ((auth-method (%make-auth-ssh-agent)))
(clone url directory
(make-clone-options
- #:fetch-options (make-fetch-options auth-method)))))
+ #:fetch-options (make-default-fetch-options)))))
(lambda _
(false-if-exception (rmdir directory)))))
@@ -300,7 +355,7 @@ it unchanged."
(not (reference-available? repository ref)))
(let ((auth-method (%make-auth-ssh-agent)))
(remote-fetch (remote-lookup repository "origin")
- #:fetch-options (make-fetch-options auth-method))))
+ #:fetch-options (make-default-fetch-options))))
(when recursive?
(update-submodules repository #:log-port log-port))