Content-addressed mirror is not used upon invalid hash

--- a/nix/libstore/build.cc

-       them. */

-    if (settings.useSubstitutes && substitutesAllowed(drv))

--- a/guix/scripts/substitute.scm

-  "Return #t if NARINFO's signature is not valid."

--- a/nix/libstore/build.cc

-       them. */

-    if (settings.useSubstitutes && substitutesAllowed(drv))

--- a/tests/substitute.scm

-  #:use-module ((guix store) #:select (%store-prefix))

--- a/Makefile.am

-  guix/build/download-nar.scm			\

--- a/guix/build/download-nar.scm

-;;; 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))))

--- a/guix/cvs-download.scm

-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>

-  #:use-module (guix modules)

-  (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))))))

-    (with-imported-modules modules

-          (use-modules (guix build cvs)

-                       (guix build download-nar))

-

-          (or (cvs-fetch '#$(cvs-reference-root-directory ref)

-                         '#$(cvs-reference-module ref)

-                         '#$(cvs-reference-revision ref)

-                         #$output

-                         #:cvs-command (string-append #+cvs "/bin/cvs"))

-              (download-nar #$output)))))

--- a/guix/git-download.scm

-  #:use-module (guix modules)

-  (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))))))

-

-    (with-imported-modules modules

-                       (guix build download-nar)

-          (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)))))

--- a/guix/hg-download.scm

-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>

-  #:use-module (guix modules)

-  (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))))))

-

-    (with-imported-modules modules

-                       (guix build download-nar))

-          (or (hg-fetch '#$(hg-reference-url ref)

-                        '#$(hg-reference-changeset ref)

-                        #$output

-                        #:hg-command (string-append #+hg "/bin/hg"))

-              (download-nar #$output)))))