From: "Ludovic Courtès" <ludo@gnu.org>
To: 43968@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#43968] [PATCH 2/3] git: Display a progress bar while fetching a repo.
Date: Mon, 12 Oct 2020 23:09:54 +0200 [thread overview]
Message-ID: <20201012210955.8753-2-ludo@gnu.org> (raw)
In-Reply-To: <20201012210955.8753-1-ludo@gnu.org>
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'.
---
guix/git.scm | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++--
1 file 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))
--
2.28.0
next prev parent reply other threads:[~2020-10-12 21:11 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-10-12 20:49 [bug#43968] [PATCH 0/3] Git progress report and proxy support Ludovic Courtès
2020-10-12 21:09 ` [bug#43968] [PATCH 1/3] git: Require Guile-Git 0.3.0 or later Ludovic Courtès
2020-10-12 21:09 ` Ludovic Courtès [this message]
2020-10-12 21:09 ` [bug#43968] [PATCH 3/3] git: Support HTTP and HTTPS proxies Ludovic Courtès
2020-10-22 15:12 ` bug#43968: [PATCH 0/3] Git progress report and proxy support Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20201012210955.8753-2-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=43968@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).