download: Download a nar when a VCS checkout fails.

Fixes <https://bugs.gnu.org/28709>.

* guix/build/download-nar.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/cvs-download.scm (cvs-fetch)[zlib, config.scm, modules]: New
variables.
[build]: Use MODULES.  Add call to 'download-nar'.
* guix/git-download.scm (git-fetch): Likewise.
* guix/hg-download.scm (hg-fetch): Likewise.

Makefile.am

@@ -106,6 +106,7 @@ MODULES =					\
   guix/ui.scm					\
   guix/build/ant-build-system.scm		\
   guix/build/download.scm			\
+  guix/build/download-nar.scm			\
   guix/build/cargo-build-system.scm		\
   guix/build/cmake-build-system.scm		\
   guix/build/dub-build-system.scm		\

guix/build/download-nar.scm

@@ -0,0 +1,125 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build download-nar)
+  #:use-module (guix build download)
+  #:use-module (guix build utils)
+  #:use-module (guix serialization)
+  #:use-module (guix zlib)
+  #:use-module (guix progress)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:export (download-nar))
+
+;;; Commentary:
+;;;
+;;; Download a normalized archive or "nar", similar to what 'guix substitute'
+;;; does.  The intent here is to use substitute servers as content-addressed
+;;; mirrors of VCS checkouts.  This is mostly useful for users who have
+;;; disabled substitutes.
+;;;
+;;; Code:
+
+(define (urls-for-item item)
+  "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.
+  ;; TODO: Use HTTPS?  The downside is the extra dependency.
+  (let ((bases '("http://mirror.hydra.gnu.org/guix"
+                 "http://berlin.guixsd.org"))
+        (item  (basename item)))
+    (append (map (cut string-append <> "/nar/gzip/" 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
+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)))))))))
+
+(define (download-nar item)
+  "Download and extract the normalized archive for ITEM.  Return #t on
+success, #f otherwise."
+  ;; Let progress reports go through.
+  (setvbuf (current-error-port) _IONBF)
+  (setvbuf (current-output-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 (((port size)
+                     (catch #t
+                       (lambda ()
+                         (http-fetch (string->uri url)))
+                       (lambda args
+                         (values #f #f)))))
+         (if (not port)
+             (loop rest)
+             (begin
+               (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)
+                   (begin
+                     ;; FIXME: Add progress report.
+                     (restore-file port item)
+                     (close-port port)))
+               #t))))
+      (()
+       #f))))

guix/cvs-download.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
@@ -23,6 +23,7 @@ (define-module (guix cvs-download)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
+  #:use-module (guix modules)
   #:use-module (guix packages)
   #:use-module (ice-9 match)
   #:export (cvs-reference
@@ -59,16 +60,35 @@ (define* (cvs-fetch ref hash-algo hash
   "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 zlib
+    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+  (define config.scm
+    (scheme-file "config.scm"
+                 #~(begin
+                     (define-module (guix config)
+                       #:export (%libz))
+
+                     (define %libz
+                       #+(file-append zlib "/lib/libz")))))
+
+  (define modules
+    (cons `((guix config) => ,config.scm)
+          (delete '(guix config)
+                  (source-module-closure '((guix build cvs)
+                                           (guix build download-nar))))))
   (define build
-    (with-imported-modules '((guix build cvs)
+    (with-imported-modules modules
-                             (guix build utils))
       #~(begin
-          (use-modules (guix build cvs))
+          (use-modules (guix build cvs)
-          (cvs-fetch '#$(cvs-reference-root-directory ref)
+                       (guix build download-nar))
-                     '#$(cvs-reference-module ref)
+
-                     '#$(cvs-reference-revision ref)
+          (or (cvs-fetch '#$(cvs-reference-root-directory ref)
-                     #$output
+                         '#$(cvs-reference-module ref)
-                     #:cvs-command (string-append #+cvs "/bin/cvs")))))
+                         '#$(cvs-reference-revision ref)
+                         #$output
+                         #:cvs-command (string-append #+cvs "/bin/cvs"))
+              (download-nar #$output)))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "cvs-checkout") build

guix/git-download.scm

@@ -25,6 +25,7 @@ (define-module (guix git-download)
   #: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)
@@ -77,12 +78,31 @@ (define inputs
         (standard-packages)
         '()))
 
+  (define zlib
+    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+  (define config.scm
+    (scheme-file "config.scm"
+                 #~(begin
+                     (define-module (guix config)
+                       #:export (%libz))
+
+                     (define %libz
+                       #+(file-append zlib "/lib/libz")))))
+
+  (define modules
+    (cons `((guix config) => ,config.scm)
+          (delete '(guix config)
+                  (source-module-closure '((guix build git)
+                                           (guix build utils)
+                                           (guix build download-nar))))))
+
   (define build
-    (with-imported-modules '((guix build git)
+    (with-imported-modules modules
-                             (guix build utils))
       #~(begin
           (use-modules (guix build git)
                        (guix build utils)
+                       (guix build download-nar)
                        (ice-9 match))
 
           ;; The 'git submodule' commands expects Coreutils, sed,
@@ -92,12 +112,13 @@ (define build
                                            (((names dirs) ...)
                                             dirs)))
 
-          (git-fetch (getenv "git url") (getenv "git commit")
+          (or (git-fetch (getenv "git url") (getenv "git commit")
-                     #$output
+                         #$output
-                     #:recursive? (call-with-input-string
+                         #:recursive? (call-with-input-string
-                                      (getenv "git recursive?")
+                                          (getenv "git recursive?")
-                                    read)
+                                        read)
-                     #:git-command (string-append #+git "/bin/git")))))
+                         #:git-command (string-append #+git "/bin/git"))
+              (download-nar #$output)))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "git-checkout") build

guix/hg-download.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -22,6 +22,7 @@ (define-module (guix hg-download)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix records)
+  #:use-module (guix modules)
   #:use-module (guix packages)
   #:autoload   (guix build-system gnu) (standard-packages)
   #:use-module (ice-9 match)
@@ -59,18 +60,35 @@ (define* (hg-fetch ref hash-algo hash
   "Return a fixed-output derivation that fetches REF, a <hg-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 zlib
+    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+  (define config.scm
+    (scheme-file "config.scm"
+                 #~(begin
+                     (define-module (guix config)
+                       #:export (%libz))
+
+                     (define %libz
+                       #+(file-append zlib "/lib/libz")))))
+
+  (define modules
+    (cons `((guix config) => ,config.scm)
+          (delete '(guix config)
+                  (source-module-closure '((guix build hg)
+                                           (guix build download-nar))))))
+
   (define build
-    (with-imported-modules '((guix build hg)
+    (with-imported-modules modules
-                             (guix build utils))
       #~(begin
           (use-modules (guix build hg)
-                       (guix build utils)
+                       (guix build download-nar))
-                       (ice-9 match))
 
-          (hg-fetch '#$(hg-reference-url ref)
+          (or (hg-fetch '#$(hg-reference-url ref)
-                    '#$(hg-reference-changeset ref)
+                        '#$(hg-reference-changeset ref)
-                    #$output
+                        #$output
-                    #:hg-command (string-append #+hg "/bin/hg")))))
+                        #:hg-command (string-append #+hg "/bin/hg"))
+              (download-nar #$output)))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "hg-checkout") build