GNU bug report logs - #33432
[PATCH 0/2] Download Git checkouts from Software Heritage as a last resort

Previous Next

Full log

View this message in rfc822 format

From: Ludovic Courtès <ludo <at> gnu.org>
To: 33432 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludovic.courtes <at> inria.fr>
Subject: [bug#33432] [PATCH 2/2] git-download: Download from Software Heritage as a last resort.
Date: Mon, 19 Nov 2018 17:24:09 +0100

From: Ludovic Courtès <ludovic.courtes <at> inria.fr>

* 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 fa94fad8f8..2689658af8 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
-- 
2.19.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.