guix: Improve download-nar.

Previously download-nar worked with gzipped nars and queried
berlin.guix.gnu.org (also known as ci.guix.gnu.org). ci.guix.gnu.org no longer
serves gzipped nars so this is of limited use.

This commit changes download-nar to query both the default substitute servers,
and queries for lzipped rather than gzipped nars, since those are available
from both.

* guix/build/download-nar.scm (urls-for-item): Return urls for lzip rather
than gzip compression, and from both default substitute servers. The comment
about CDN's is no longer relevant.
(restore-gzipped-nar): Rename to restore-lzipped-nar and reimplement
accordingly.
(download-nar): Add progress reporting and switch to use lzip rather than
gzip.
* guix/cvs-download.scm (cvs-fetch): Replace guile-zlib with guile-lzlib.
* guix/git-download.scm (git-fetch): Replace guile-zlib with guile-lzlib.
* guix/hg-download.scm (hg-fetch): Replace guile-zlib with guile-lzlib.
* guix/android-repo-download.scm (android-repo-fetch): Add guile-lzlib for
download-nar.

Signed-off-by: Christopher Baines <mail@cbaines.net>

5 files changed, 39 insertions, 58 deletions

diff --git a/guix/android-repo-download.scm b/guix/android-repo-download.scm
index e224cdd295..1d1b9e2f09 100644
--- a/guix/android-repo-download.scm
+++ b/guix/android-repo-download.scm
@@ -78,6 +78,9 @@ generic name if unset."
   (define guile-json
     (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
 
+  (define guile-lzlib
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib))
+
   (define gnutls
     (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
 
@@ -99,7 +102,8 @@ generic name if unset."
 
   (define build
     (with-imported-modules modules
-      (with-extensions (list gnutls guile-json) ;for (guix swh)
+      (with-extensions (list gnutls guile-json ;for (guix swh)
+                             guile-lzlib)
         #~(begin
             (use-modules (guix build android-repo)
                          (guix build utils)
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
index d760f3ce00..1b5b5503eb 100644
--- a/guix/build/download-nar.scm
+++ b/guix/build/download-nar.scm
@@ -19,7 +19,7 @@
 (define-module (guix build download-nar)
   #:use-module (guix build download)
   #:use-module ((guix serialization) #:hide (dump-port*))
-  #:autoload   (zlib) (call-with-gzip-input-port)
+  #:autoload   (lzlib) (call-with-lzip-input-port)
   #:use-module (guix progress)
   #:use-module (web uri)
   #:use-module (srfi srfi-11)
@@ -41,52 +41,21 @@
   "Return the fallback nar URL for ITEM--e.g.,
 \"/gnu/store/cabbag3…-foo-1.2-checkout\"."
   ;; Here we hard-code nar URLs without checking narinfos.  That's probably OK
-  ;; though.  Use berlin.guix.gnu.org instead of its ci.guix.gnu.org front end to
-  ;; avoid sending these requests to CDN providers without user consent.
+  ;; though.
   ;; TODO: Use HTTPS?  The downside is the extra dependency.
-  (let ((bases '("http://berlin.guix.gnu.org"))
+  (let ((bases '("http://bordeaux.guix.gnu.org"
+                 "http://ci.guix.gnu.org"))
         (item  (basename item)))
-    (append (map (cut string-append <> "/nar/gzip/" item) bases)
+    (append (map (cut string-append <> "/nar/lzip/" item) bases)
             (map (cut string-append <> "/nar/" item) bases))))
 
-(define (restore-gzipped-nar port item size)
-  "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to
+(define (restore-lzipped-nar port item size)
+  "Restore the lzipped nar read from PORT, of SIZE bytes (compressed), to
 ITEM."
-  ;; Since PORT is typically a non-file port (for instance because 'http-get'
-  ;; returns a delimited port), create a child process so we're back to a file
-  ;; port that can be passed to 'call-with-gzip-input-port'.
-  (match (pipe)
-    ((input . output)
-     (match (primitive-fork)
-       (0
-        (dynamic-wind
-          (const #t)
-          (lambda ()
-            (close-port output)
-            (close-port port)
-            (catch #t
-              (lambda ()
-                (call-with-gzip-input-port input
-                  (cut restore-file <> item)))
-              (lambda (key . args)
-                (print-exception (current-error-port)
-                                 (stack-ref (make-stack #t) 1)
-                                 key args)
-                (primitive-exit 1))))
-          (lambda ()
-            (primitive-exit 0))))
-       (child
-        (close-port input)
-        (dump-port* port output
-                    #:reporter (progress-reporter/file item size
-                                                       #:abbreviation
-                                                       store-path-abbreviation))
-        (close-port output)
-        (newline)
-        (match (waitpid child)
-          ((_ . status)
-           (unless (zero? status)
-             (error "nar decompression failed" status)))))))))
+  (call-with-lzip-input-port port
+    (lambda (decompressed-port)
+      (restore-file decompressed-port
+                    item))))
 
 (define (download-nar item)
   "Download and extract the normalized archive for ITEM.  Return #t on
@@ -108,17 +77,25 @@ success, #f otherwise."
                          (values #f #f)))))
          (if (not port)
              (loop rest)
-             (begin
+             (let* ((reporter (progress-reporter/file
+                               url
+                               size
+                               (current-error-port)
+                               #:abbreviation nar-uri-abbreviation))
+                    (port-with-progress
+                     (progress-report-port reporter port
+                                           #:download-size size)))
                (if size
                    (format #t "Downloading from ~a (~,2h MiB)...~%" url
                            (/ size (expt 2 20.)))
                    (format #t "Downloading from ~a...~%" url))
-               (if (string-contains url "/gzip")
-                   (restore-gzipped-nar port item size)
+               (if (string-contains url "/lzip")
+                   (restore-lzipped-nar port-with-progress
+                                        item
+                                        size)
                    (begin
-                     ;; FIXME: Add progress report.
-                     (restore-file port item)
-                     (close-port port)))
+                     (restore-file port-with-progress
+                                   item)))
                #t))))
       (()
        #f))))
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 943d971622..22af2461e9 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -61,8 +61,8 @@
   "Return a fixed-output derivation that fetches REF, a <cvs-reference>
 object.  The output is expected to have recursive hash HASH of type
 HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
-  (define guile-zlib
-    (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
+  (define guile-lzlib
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib))
 
   (define guile-json
     (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
@@ -77,7 +77,7 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   (define build
     (with-imported-modules modules
       (with-extensions (list guile-json gnutls ;for (guix swh)
-                             guile-zlib)
+                             guile-lzlib)
         #~(begin
             (use-modules (guix build cvs)
                          (guix build download-nar))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 3dc306e39d..027ef47468 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -101,8 +101,8 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   (define guile-json
     (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
 
-  (define guile-zlib
-    (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
+  (define guile-lzlib
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib))
 
   (define gnutls
     (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
@@ -123,7 +123,7 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   (define build
     (with-imported-modules modules
       (with-extensions (list guile-json gnutls   ;for (guix swh)
-                             guile-zlib)
+                             guile-lzlib)
         #~(begin
             (use-modules (guix build git)
                          (guix build utils)
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index a7022dd431..13135082fa 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -72,8 +72,8 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
       ("tar" ,(module-ref (resolve-interface '(gnu packages base))
                           'tar))))
 
-  (define guile-zlib
-    (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
+  (define guile-lzlib
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib))
 
   (define guile-json
     (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
@@ -90,7 +90,7 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   (define build
     (with-imported-modules modules
       (with-extensions (list guile-json gnutls ;for (guix swh)
-                             guile-zlib)
+                             guile-lzlib)
         #~(begin
             (use-modules (guix build hg)
                          (guix build utils) ;for `set-path-environment-variable'