From 608d3dca89d73fe7260e97a284a8aeea756a3e11 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludovic.courtes@inria.fr>
Date: Mon, 19 Nov 2018 15:46:50 +0100
Subject: [PATCH] git-download: Download from Software Heritage as a last
 resort.

* guix/git-download.scm (git-fetch)[inputs]: Add gzip and tar when
'git-reference-recursive?' is false.
[guile-json, gnutls]: New variables.
[modules]: Add (guix swh).
[build]: Wrap in 'with-extensions'.  Add call to 'swh-download'.
---
 guix/git-download.scm | 64 +++++++++++++++++++++++++++++--------------
 1 file changed, 44 insertions(+), 20 deletions(-)

diff --git a/guix/git-download.scm b/guix/git-download.scm
index 072ab51538..6cf267d6c8 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -74,11 +74,22 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
     ;; available so that 'git submodule' works.
     (if (git-reference-recursive? ref)
         (standard-packages)
-        '()))
+
+        ;; The 'swh-download' procedure requires tar and gzip.
+        `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
+                               'gzip))
+          ("tar" ,(module-ref (resolve-interface '(gnu packages base))
+                              'tar)))))
 
   (define zlib
     (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
 
+  (define guile-json
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-json))
+
+  (define gnutls
+    (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
+
   (define config.scm
     (scheme-file "config.scm"
                  #~(begin
@@ -93,30 +104,43 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
           (delete '(guix config)
                   (source-module-closure '((guix build git)
                                            (guix build utils)
-                                           (guix build download-nar))))))
+                                           (guix build download-nar)
+                                           (guix swh))))))
 
   (define build
     (with-imported-modules modules
-      #~(begin
-          (use-modules (guix build git)
-                       (guix build utils)
-                       (guix build download-nar)
-                       (ice-9 match))
+      (with-extensions (list guile-json gnutls)   ;for (guix swh)
+        #~(begin
+            (use-modules (guix build git)
+                         (guix build utils)
+                         (guix build download-nar)
+                         (guix swh)
+                         (ice-9 match))
 
-          ;; The 'git submodule' commands expects Coreutils, sed,
-          ;; grep, etc. to be in $PATH.
-          (set-path-environment-variable "PATH" '("bin")
-                                         (match '#+inputs
-                                           (((names dirs outputs ...) ...)
-                                            dirs)))
+            (define recursive?
+              (call-with-input-string (getenv "git recursive?") read))
 
-          (or (git-fetch (getenv "git url") (getenv "git commit")
-                         #$output
-                         #:recursive? (call-with-input-string
-                                          (getenv "git recursive?")
-                                        read)
-                         #:git-command (string-append #+git "/bin/git"))
-              (download-nar #$output)))))
+            ;; The 'git submodule' commands expects Coreutils, sed,
+            ;; grep, etc. to be in $PATH.
+            (set-path-environment-variable "PATH" '("bin")
+                                           (match '#+inputs
+                                             (((names dirs outputs ...) ...)
+                                              dirs)))
+
+            (setvbuf (current-output-port) 'line)
+            (setvbuf (current-error-port) 'line)
+
+            (or (git-fetch (getenv "git url") (getenv "git commit")
+                           #$output
+                           #:recursive? recursive?
+                           #:git-command (string-append #+git "/bin/git"))
+                (download-nar #$output)
+
+                ;; As a last resort, attempt to download from Software Heritage.
+                ;; XXX: Currently recursive checkouts are not supported.
+                (and (not recursive?)
+                     (swh-download (getenv "git url") (getenv "git commit")
+                                   #$output)))))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "git-checkout") build