Merge branch 'master' into core-updates

 Conflicts:
	gnu/local.mk
	gnu/packages/bioinformatics.scm
	gnu/packages/django.scm
	gnu/packages/gtk.scm
	gnu/packages/llvm.scm
	gnu/packages/python-web.scm
	gnu/packages/python.scm
	gnu/packages/tex.scm
	guix/build-system/asdf.scm
	guix/build/emacs-build-system.scm
	guix/profiles.scm

1 files changed, 50 insertions, 35 deletions

diff --git a/guix/swh.scm b/guix/swh.scm
index f11b7ea2d5..3005323fd1 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -108,6 +108,7 @@
 
             commit-id?
 
+            swh-download-directory
             swh-download))
 
 ;;; Commentary:
@@ -147,12 +148,20 @@
       url
       (string-append url "/")))
 
-;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would
-;; be ignored (<https://bugs.gnu.org/40486>).
-(define* (http-get* uri #:rest rest)
-  (apply http-request uri #:method 'GET rest))
-(define* (http-post* uri #:rest rest)
-  (apply http-request uri #:method 'POST rest))
+(cond-expand
+  (guile-3
+   ;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would
+   ;; be ignored (<https://bugs.gnu.org/40486>).
+   (define* (http-get* uri #:rest rest)
+     (apply http-request uri #:method 'GET rest))
+   (define* (http-post* uri #:rest rest)
+     (apply http-request uri #:method 'POST rest)))
+  (else                                           ;Guile 2.2
+   ;; Guile 2.2 did not have #:verify-certificate? so ignore it.
+   (define* (http-get* uri #:key verify-certificate? streaming?)
+     (http-request uri #:method 'GET #:streaming? streaming?))
+   (define* (http-post* uri #:key verify-certificate? streaming?)
+     (http-request uri #:method 'POST #:streaming? streaming?))))
 
 (define %date-regexp
   ;; Match strings like "2014-11-17T22:09:38+01:00" or
@@ -558,12 +567,6 @@ requested bundle cooking, waiting for completion...~%"))
 ;;; High-level interface.
 ;;;
 
-(define (commit-id? reference)
-  "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
-it is a tag name.  This is based on a simple heuristic so use with care!"
-  (and (= (string-length reference) 40)
-       (string-every char-set:hex-digit reference)))
-
 (define (call-with-temporary-directory proc)      ;FIXME: factorize
   "Call PROC with a name of a temporary directory; close the directory and
 delete it when leaving the dynamic extent of this call."
@@ -577,6 +580,39 @@ delete it when leaving the dynamic extent of this call."
       (lambda ()
         (false-if-exception (delete-file-recursively tmp-dir))))))
 
+(define* (swh-download-directory id output
+                                 #:key (log-port (current-error-port)))
+  "Download from Software Heritage the directory with the given ID, and
+unpack it to OUTPUT.  Return #t on success and #f on failure"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (match (vault-fetch id 'directory #:log-port log-port)
+       (#f
+        (format log-port
+                "SWH: directory ~a could not be fetched from the vault~%"
+                id)
+        #f)
+       ((? port? input)
+        (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
+          (dump-port input tar)
+          (close-port input)
+          (let ((status (close-pipe tar)))
+            (unless (zero? status)
+              (error "tar extraction failure" status)))
+
+          (match (scandir directory)
+            (("." ".." sub-directory)
+             (copy-recursively (string-append directory "/" sub-directory)
+                               output
+                               #:log (%make-void-port "w"))
+             #t))))))))
+
+(define (commit-id? reference)
+  "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
+it is a tag name.  This is based on a simple heuristic so use with care!"
+  (and (= (string-length reference) 40)
+       (string-every char-set:hex-digit reference)))
+
 (define* (swh-download url reference output
                        #:key (log-port (current-error-port)))
   "Download from Software Heritage a checkout of the Git tag or commit
@@ -593,28 +629,7 @@ wait until it becomes available, which could take several minutes."
      (format log-port "SWH: found revision ~a with directory at '~a'~%"
              (revision-id revision)
              (swh-url (revision-directory-url revision)))
-     (call-with-temporary-directory
-      (lambda (directory)
-        (match (vault-fetch (revision-directory revision) 'directory
-                            #:log-port log-port)
-          (#f
-           (format log-port
-                   "SWH: directory ~a could not be fetched from the vault~%"
-                   (revision-directory revision))
-           #f)
-          ((? port? input)
-           (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
-             (dump-port input tar)
-             (close-port input)
-             (let ((status (close-pipe tar)))
-               (unless (zero? status)
-                 (error "tar extraction failure" status)))
-
-             (match (scandir directory)
-               (("." ".." sub-directory)
-                (copy-recursively (string-append directory "/" sub-directory)
-                                  output
-                                  #:log (%make-void-port "w"))
-                #t))))))))
+     (swh-download-directory (revision-directory revision) output
+                             #:log-port log-port))
     (#f
      #f)))