bug#28709: Content-addressed mirrors for Git checkouts

[Ludovic Courtès]

Hello!

Someone on #guix reported a failure to build Guile-Git from Guix 0.13.0
because the old repo at gitlab.com has disappeared.

For tarballs, we have content addressed mirrors, in particular the /file
URL of ‘guix publish’.  However, that’s only for regular files, not for
directories like Git checkouts.

For directories (and store items in general), we have the /nar URLs
though (normally used for substitutes).  This patch uses /nar URLs as a
fallback mirror (it’s content-addressed, even though the hash in the URL
is not directly the content hash) for Git clones that fail.

It’s rough on the edges (no TLS, no compression), but it shows that it’s
a viable solution.  It would take some thought to avoid duplicating it
between git, hg, etc.

Thoughts?

Ludo’.

diff --git a/guix/build/git.scm b/guix/build/git.scm
index c1af545a7..223e79227 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,7 +17,14 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build git)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (guix serialization)
   #:use-module (guix build utils)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
   #:export (git-fetch))
 
 ;;; Commentary:
@@ -27,6 +34,37 @@
 ;;;
 ;;; Code:
 
+(define (urls-for-item item)
+  "Return the fallback nar URL for ITEM--e.g., \"cabbag3…-foo-1.2-checkout\"."
+  ;; TODO: Use the /gzip URLs, make it configurable, and use TLS.
+  (list (string-append "http://mirror.hydra.gnu.org/guix/nar/"; item)
+        (string-append "http://berlin.guixsd.org/nar/"; item)))
+
+(define (download-nar item directory)
+  "Download Git checkout ITEM to DIRECTORY as a nar."
+  (setvbuf (current-output-port) _IONBF)
+  (setvbuf (current-error-port) _IONBF)
+
+  (let loop ((urls (urls-for-item item)))
+    (match urls
+      ((url rest ...)
+       (format #t "Trying content-addressed mirror at ~a...~%"
+               (uri-host (string->uri url)))
+       (let-values (((response port)
+                     (http-get url #:streaming? #t)))
+         (if (= 200 (response-code response))
+             (let ((size (response-content-length response)))
+               (if size
+                   (format #t "Downloading from ~a (~,2h MiB)...~%"
+                           url (/ size (expt 2 20.)))
+                   (format #t "Downloading from ~a...~%" url))
+               (restore-file port directory)
+               (close-port port)
+               #t)
+             (loop rest))))
+      (()
+       #f))))
+
 (define* (git-fetch url commit directory
                     #:key (git-command "git") recursive?)
   "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
@@ -39,26 +77,27 @@ recursively.  Return #t on success, #f otherwise."
 
   ;; We cannot use "git clone --recursive" since the following "git checkout"
   ;; effectively removes sub-module checkouts as of Git 2.6.3.
-  (and (zero? (system* git-command "clone" url directory))
-       (with-directory-excursion directory
-         (system* git-command "tag" "-l")
-         (and (zero? (system* git-command "checkout" commit))
-              (begin
-                (when recursive?
-                  ;; Now is the time to fetch sub-modules.
-                  (unless (zero? (system* git-command "submodule" "update"
-                                          "--init" "--recursive"))
-                    (error "failed to fetch sub-modules" url))
+  (if (zero? (system* git-command "clone" url directory))
+      (with-directory-excursion directory
+        (system* git-command "tag" "-l")
+        (and (zero? (system* git-command "checkout" commit))
+             (begin
+               (when recursive?
+                 ;; Now is the time to fetch sub-modules.
+                 (unless (zero? (system* git-command "submodule" "update"
+                                         "--init" "--recursive"))
+                   (error "failed to fetch sub-modules" url))
 
-                  ;; In sub-modules, '.git' is a flat file, not a directory,
-                  ;; so we can use 'find-files' here.
-                  (for-each delete-file-recursively
-                            (find-files directory "^\\.git$")))
+                 ;; In sub-modules, '.git' is a flat file, not a directory,
+                 ;; so we can use 'find-files' here.
+                 (for-each delete-file-recursively
+                           (find-files directory "^\\.git$")))
 
-                ;; The contents of '.git' vary as a function of the current
-                ;; status of the Git repo.  Since we want a fixed output, this
-                ;; directory needs to be taken out.
-                (delete-file-recursively ".git")
-                #t)))))
+               ;; The contents of '.git' vary as a function of the current
+               ;; status of the Git repo.  Since we want a fixed output, this
+               ;; directory needs to be taken out.
+               (delete-file-recursively ".git")
+               #t)))
+      (download-nar (basename directory) directory)))
 
 ;;; git.scm ends here
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 7397cbe7f..ffae8fcc3 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -25,6 +25,7 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix packages)
+  #:use-module (guix modules)
   #:autoload   (guix build-system gnu) (standard-packages)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
@@ -78,8 +79,8 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
         '()))
 
   (define build
-    (with-imported-modules '((guix build git)
-                             (guix build utils))
+    (with-imported-modules (source-module-closure
+                            '((guix build git)))
       #~(begin
           (use-modules (guix build git)
                        (guix build utils)