bug#28659: Always enable substitutes for fixed-output derivations

[ludo@gnu.org (Ludovic Courtès)]

[-- Attachment #1: Type: text/plain, Size: 876 bytes --]

ludo@gnu.org (Ludovic Courtès) skribis:

> So I think we have to communicate more info from the daemon to ‘guix
> substitute’.

The attached patch addresses that by simply calling out to the daemon to
determine whether we’re dealing with a content-addressed item.

To summarize, the new behavior is that substitutes are always enabled
for fixed-output derivations.  That way, people willing to build
everything from source can still use ‘--no-substitutes’ and yet be able
to retrieve source code without being penalized compared to someone
enabling substitutes wholesale.

Of course, when substitutes are missing, we fall back to regular
downloads or VCS checkouts.  It is also still possible to choose where
substitutes are downloaded from, using ‘--substitute-urls’, or even to
pass an empty list of URLs.

Feedback welcome!

Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-substitute-Always-allow-substitutes-for-fixed-output.patch --]
[-- Type: text/x-patch, Size: 5940 bytes --]

From aab42bcb212698bc1f61beb9f321ffbd751f36f5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 15 Dec 2017 09:57:04 +0100
Subject: [PATCH 1/2] substitute: Always allow substitutes for fixed-output
 derivation results.

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

* guix/scripts/substitute.scm (content-addressed-item?): New procedure.
(valid-narinfo?): Use it.
* nix/libstore/build.cc (DerivationGoal::haveDerivation): Always make a
substitution goal when 'fixedOutput' is true.
* tests/substitute.scm ("query unsigned narinfo for content-addressed
item"): New test.
---
 guix/scripts/substitute.scm | 31 ++++++++++++++++++++++++++++++-
 nix/libstore/build.cc       |  6 ++++--
 tests/substitute.scm        | 24 +++++++++++++++++++++++-
 3 files changed, 57 insertions(+), 4 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 2fd2bf810..670a9b4dd 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -25,6 +25,9 @@
   #:use-module (guix config)
   #:use-module (guix records)
   #:use-module ((guix serialization) #:select (restore-file))
+  #:use-module ((guix derivations)
+                #:select (read-derivation-from-file
+                          fixed-output-derivation?))
   #:use-module (guix hash)
   #:use-module (guix base32)
   #:use-module (guix base64)
@@ -406,10 +409,36 @@ No authentication and authorization checks are performed here!"
        (let ((above-signature (string-take contents index)))
          (sha256 (string->utf8 above-signature)))))))
 
+(define* (content-addressed-item? item)
+  "Return true if ITEM is content-addressed---i.e., if ITEM is the result of a
+fixed-output derivation."
+  (guard (c ((nix-connection-error? c)
+             ;; We failed to connect, maybe because we have the wrong
+             ;; GUIX_DAEMON_SOCKET?  Let's conservatively assume that
+             ;; nothing's content-addressed.
+             #f))
+    (with-store store
+      (match (valid-derivers store item)
+        (()
+         ;; If there are no valid derivers it's most likely because ITEM is a
+         ;; source (added with 'add-to-store' or similar).  Nevertheless,
+         ;; since we can't be certain, return #f.
+         #f)
+        ((drv . _)
+         (fixed-output-derivation?
+          (read-derivation-from-file drv)))))))
+
 (define* (valid-narinfo? narinfo #:optional (acl (current-acl))
                          #:key verbose?)
-  "Return #t if NARINFO's signature is not valid."
+  "Return #t if NARINFO is \"valid\"---signed by an authorized key, or
+designating a content-addressed item."
   (or %allow-unauthenticated-substitutes?
+
+      ;; If NARINFO designates a content-addressed item, there's no point
+      ;; authenticating it.  Don't explicitly check 'narinfo-hash' for
+      ;; integrity: this will be done by the daemon once we've downloaded it.
+      (content-addressed-item? (narinfo-path narinfo))
+
       (let ((hash      (narinfo-sha256 narinfo))
             (signature (narinfo-signature narinfo))
             (uri       (uri->string (narinfo-uri narinfo))))
diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc
index d68e8b2bc..03a8f5080 100644
--- a/nix/libstore/build.cc
+++ b/nix/libstore/build.cc
@@ -1034,8 +1034,10 @@ void DerivationGoal::haveDerivation()
 
     /* We are first going to try to create the invalid output paths
        through substitutes.  If that doesn't work, we'll build
-       them. */
-    if (settings.useSubstitutes && substitutesAllowed(drv))
+       them.  Always enable substitutes for fixed-output derivations to
+       protect against disappearing files and in-place modifications on
+       upstream sites.  */
+    if ((fixedOutput || settings.useSubstitutes) && substitutesAllowed(drv))
         foreach (PathSet::iterator, i, invalidOutputs)
             addWaitee(worker.makeSubstitutionGoal(*i, buildMode == bmRepair));
 
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 0ad624795..03579b9f1 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -21,15 +21,17 @@
   #:use-module (guix scripts substitute)
   #:use-module (guix base64)
   #:use-module (guix hash)
+  #:use-module (guix derivations)
   #:use-module (guix serialization)
   #:use-module (guix pk-crypto)
   #:use-module (guix pki)
   #:use-module (guix config)
   #:use-module (guix base32)
-  #:use-module ((guix store) #:select (%store-prefix))
+  #:use-module ((guix store) #:select (%store-prefix with-store))
   #:use-module ((guix ui) #:select (guix-warning-port))
   #:use-module ((guix build utils)
                 #:select (mkdir-p delete-file-recursively))
+  #:use-module (guix tests)
   #:use-module (guix tests http)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
@@ -241,6 +243,26 @@ a file for NARINFO."
            (lambda ()
              (guix-substitute "--query"))))))))
 
+(test-assert "query unsigned narinfo for content-addressed item"
+  (with-store store
+    (let* ((hash (sha256 (random-bytevector 128)))
+           (drv  (derivation store "content-addressed"
+                             "builtin:download" '()
+                             #:hash-algo 'sha256 #:hash hash)))
+      (define output
+        (with-output-to-string
+          (lambda ()
+            (with-derivation-narinfo drv (sha256 => hash)
+              (with-input-from-string (string-append "have "
+                                                     (derivation->output-path drv))
+                (lambda ()
+                  (set! (@@ (guix scripts substitute)
+                            %allow-unauthenticated-substitutes?)
+                    #f)
+                  (guix-substitute "--query")))))))
+
+      (string=? (string-trim-both output) (derivation->output-path drv)))))
+
 (test-quit "substitute, no signature"
     "no valid substitute"
   (with-narinfo %narinfo
-- 
2.15.1


[-- Attachment #3: 0002-Revert-download-Download-a-nar-when-a-VCS-checkout-f.patch --]
[-- Type: text/x-patch, Size: 14302 bytes --]

From 9bcf90b99a79f9f3e126cde5fe1cf51b0dfa58aa Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 15 Dec 2017 10:03:39 +0100
Subject: [PATCH 2/2] Revert "download: Download a nar when a VCS checkout
 fails."

This reverts commit 37ce440dcffa9ff4f5401bacbc9619bd8ea561c1, which is
useless now that substitutes are always enabled for content-addressed
items.
---
 Makefile.am                 |   1 -
 guix/build/download-nar.scm | 125 --------------------------------------------
 guix/cvs-download.scm       |  38 ++++----------
 guix/git-download.scm       |  37 +++----------
 guix/hg-download.scm        |  36 ++++---------
 5 files changed, 26 insertions(+), 211 deletions(-)
 delete mode 100644 guix/build/download-nar.scm

diff --git a/Makefile.am b/Makefile.am
index 85b9ab36d..d2660b0a7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -110,7 +110,6 @@ 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		\
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
deleted file mode 100644
index 13f01fb1e..000000000
--- a/guix/build/download-nar.scm
+++ /dev/null
@@ -1,125 +0,0 @@
-;;; 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))))
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 8b46f8ef8..85744c5b5 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
@@ -23,7 +23,6 @@
   #: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
@@ -60,35 +59,16 @@
   "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 modules
+    (with-imported-modules '((guix build cvs)
+                             (guix build utils))
       #~(begin
-          (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)))))
+          (use-modules (guix build cvs))
+          (cvs-fetch '#$(cvs-reference-root-directory ref)
+                     '#$(cvs-reference-module ref)
+                     '#$(cvs-reference-revision ref)
+                     #$output
+                     #:cvs-command (string-append #+cvs "/bin/cvs")))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "cvs-checkout") build
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 731e549b3..7397cbe7f 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -25,7 +25,6 @@
   #: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)
@@ -78,31 +77,12 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
         (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 modules
+    (with-imported-modules '((guix build git)
+                             (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,
@@ -112,13 +92,12 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                                            (((names dirs) ...)
                                             dirs)))
 
-          (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)))))
+          (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")))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "git-checkout") build
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 6b25b87b6..842098090 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -22,7 +22,6 @@
   #: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)
@@ -60,35 +59,18 @@
   "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 modules
+    (with-imported-modules '((guix build hg)
+                             (guix build utils))
       #~(begin
           (use-modules (guix build hg)
-                       (guix build download-nar))
+                       (guix build utils)
+                       (ice-9 match))
 
-          (or (hg-fetch '#$(hg-reference-url ref)
-                        '#$(hg-reference-changeset ref)
-                        #$output
-                        #:hg-command (string-append #+hg "/bin/hg"))
-              (download-nar #$output)))))
+          (hg-fetch '#$(hg-reference-url ref)
+                    '#$(hg-reference-changeset ref)
+                    #$output
+                    #:hg-command (string-append #+hg "/bin/hg")))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "hg-checkout") build
-- 
2.15.1