[bug#43968] [PATCH 0/3] Git progress report and proxy support

[bug#43968] [PATCH 0/3] Git progress report and proxy support

[Ludovic Courtès]

Hello Guix!

This patch series closes two gaps:

  1. Lack of HTTP/HTTPS proxy support for Git clones/fetches as
     made by ‘guix pull’, ‘--with-branch’, etc.

  2. Lack of progress report for clones/fetches, which is a serious
     issue for big repos like that of Guix, which can take a couple
     of minutes to fetch: <https://issues.guix.gnu.org/39260>.
     This is also the first experience of ‘guix pull’ that people
     have: seemingly nothing happens during a couple of minutes.

I tested it with Guile-Git commit d418a854a3785b9ae96741f4c755517e29224197,
which should become 0.4.0 soonish.

Ludo’.

Ludovic Courtès (3):
  git: Require Guile-Git 0.3.0 or later.
  git: Display a progress bar while fetching a repo.
  git: Support HTTP and HTTPS proxies.

 configure.ac  |   5 ++
 doc/guix.texi |   4 +-
 guix/git.scm  | 140 ++++++++++++++++++++++++++++----------------------
 m4/guix.m4    |  22 ++++++++
 4 files changed, 109 insertions(+), 62 deletions(-)

-- 
2.28.0

[bug#43968] [PATCH 1/3] git: Require Guile-Git 0.3.0 or later.

[Ludovic Courtès]

* guix/git.scm (auth-supported?): Remove.
(clone*): Inline code that was dependent on AUTH-SUPPORTED?.
(update-cached-checkout): Likewise.
(resolve-reference): Remove check for 'object-lookup-prefix' and use it
unconditionally.
(load-git-submodules): Remove.
(update-submodules): Use 'repository-submodules', 'submodule-lookup',
etc. unconditionally.
(update-cached-checkout): Use 'repository-close!' unconditionally.
* m4/guix.m4 (GUIX_CHECK_GUILE_GIT): New macro.
* configure.ac: Use it and error out when it fails.
* doc/guix.texi (Requirements): Bump to Guile-Git 0.3.0.
---
 configure.ac  |  5 +++
 doc/guix.texi |  4 +--
 guix/git.scm  | 84 ++++++++++++++-------------------------------------
 m4/guix.m4    | 22 ++++++++++++++
 4 files changed, 52 insertions(+), 63 deletions(-)

diff --git a/configure.ac b/configure.ac
index 6861112eaf..6e718afdd1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -144,6 +144,11 @@ if test "x$guix_cv_have_recent_guile_gcrypt" != "xyes"; then
   AC_MSG_ERROR([A recent Guile-Gcrypt could not be found; please install it.])
 fi
 
+GUIX_CHECK_GUILE_GIT
+if test "x$guix_cv_have_recent_guile_git" != "xyes"; then
+  AC_MSG_ERROR([A recent Guile-Git could not be found; please install it.])
+fi
+
 dnl Check for Guile-zlib.
 GUILE_MODULE_AVAILABLE([have_guile_zlib], [(zlib)])
 if test "x$have_guile_zlib" != "xyes"; then
diff --git a/doc/guix.texi b/doc/guix.texi
index 7150adeaa8..73156e9492 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -809,8 +809,8 @@ or later;
 @item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib};
 @item
 @c FIXME: Specify a version number once a release has been made.
-@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August
-2017 or later;
+@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, version 0.3.0
+or later;
 @item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON}
 4.3.0 or later;
 @item @url{https://www.gnu.org/software/make/, GNU Make}.
diff --git a/guix/git.scm b/guix/git.scm
index 637936c16a..cfb8d626f5 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)
@@ -116,10 +117,6 @@ 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 (clone* url directory)
   "Clone git repository at URL into DIRECTORY.  Upon failure,
 make sure no empty directory is left behind."
@@ -127,18 +124,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-fetch-options auth-method)))))
     (lambda _
       (false-if-exception (rmdir directory)))))
 
@@ -167,12 +156,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 +218,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)
+  (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.~%"))))
+                ;; 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 +298,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-fetch-options auth-method))))
      (when recursive?
        (update-submodules repository #:log-port log-port))
 
@@ -359,9 +323,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)))))
 
diff --git a/m4/guix.m4 b/m4/guix.m4
index 2fcc65e039..4fa7cdf737 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -204,6 +204,28 @@ AC_DEFUN([GUIX_CHECK_GUILE_GCRYPT], [
      fi])
 ])
 
+dnl GUIX_CHECK_GUILE_GIT
+dnl
+dnl Check whether a recent-enough Guile-Git is available.
+AC_DEFUN([GUIX_CHECK_GUILE_GIT], [
+  dnl Check whether we're using Guile-Git 0.3.0 or later.  0.3.0
+  dnl introduced SSH authentication support and more.
+  AC_CACHE_CHECK([whether Guile-Git is available and recent enough],
+    [guix_cv_have_recent_guile_git],
+    [GUILE_CHECK([retval],
+      [(use-modules (git) (git auth) (git submodule))
+       (let ((auth (%make-auth-ssh-agent)))
+         repository-close!
+	 object-lookup-prefix
+         (make-clone-options
+          #:fetch-options (make-fetch-options auth)))])
+     if test "$retval" = 0; then
+       guix_cv_have_recent_guile_git="yes"
+     else
+       guix_cv_have_recent_guile_git="no"
+     fi])
+])
+
 dnl GUIX_TEST_ROOT_DIRECTORY
 AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
   AC_CACHE_CHECK([for unit test root directory],
-- 
2.28.0

[bug#43968] [PATCH 2/3] git: Display a progress bar while fetching a repo.

[Ludovic Courtès]

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

[bug#43968] [PATCH 3/3] git: Support HTTP and HTTPS proxies.

[Ludovic Courtès]

This allows 'guix pull' and similar to fetch code over a proxy.

* guix/git.scm (make-default-fetch-options): Pass #:proxy-url.
---
 guix/git.scm | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index b81a011443..364b4997ae 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -161,11 +161,14 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
 (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.
+    ;; 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)))
-- 
2.28.0

bug#43968: [PATCH 0/3] Git progress report and proxy support

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

>   git: Require Guile-Git 0.3.0 or later.
>   git: Display a progress bar while fetching a repo.
>   git: Support HTTP and HTTPS proxies.

Pushed as 8425a9b60a75d95000634bee518d9fd1cf1b4d8b.

Ludo'.