Merge branch 'master' into core-updates

30 files changed, 1071 insertions, 794 deletions

diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index b42f498a80..a40c3f96de 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -170,8 +170,8 @@ SEARCH-PATHS."
       (display "\
 ;; This file was automatically generated and is for internal use only.
 ;; It cannot be passed to the '--manifest' option.
-;; Run 'guix package --export-manifest' if to export a file suitable
-;; for '--manifest'.\n\n"
+;; Run 'guix package --export-manifest' if you want to export a file
+;; suitable for '--manifest'.\n\n"
                p)
       (pretty-print manifest p)))
 
diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm
index 464fc97b13..66683971c5 100644
--- a/guix/build/renpy-build-system.scm
+++ b/guix/build/renpy-build-system.scm
@@ -57,7 +57,7 @@
       (delete-file (string-append data "/renpy-build.json"))
       (call-with-output-file launcher
         (lambda (port)
-          (format port "#!~a~%~a ~a \"$@\""
+          (format port "#!~a~%~a ~s \"$@\""
                   (which "bash")
                   (which "renpy")
                   data)))
@@ -77,8 +77,9 @@
      (string-append out "/share/applications/" executable-name ".desktop")
      #:name (assoc-ref json-dump "name")
      #:generic-name (assoc-ref build "display_name")
-     #:exec (string-append (which "renpy") " "
-                           out "/share/renpy/" directory-name)
+     #:exec (format #f "~a ~s"
+                    (which "renpy")
+                    (string-append out "/share/renpy/" directory-name))
      #:categories '("Game" "Visual Novel")))
   #t)
 
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 85c1c45f81..552343a481 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -43,9 +43,10 @@
             MS_NOEXEC
             MS_REMOUNT
             MS_NOATIME
+            MS_STRICTATIME
+            MS_RELATIME
             MS_BIND
             MS_MOVE
-            MS_STRICTATIME
             MS_LAZYTIME
             MNT_FORCE
             MNT_DETACH
@@ -53,7 +54,18 @@
             UMOUNT_NOFOLLOW
 
             restart-on-EINTR
+
+            mount?
+            mount-device-number
+            mount-source
+            mount-point
+            mount-type
+            mount-options
+            mount-flags
+
+            mounts
             mount-points
+
             swapon
             swapoff
 
@@ -466,6 +478,7 @@ the returned procedure is called."
 (define MS_NOATIME         1024)
 (define MS_BIND            4096)
 (define MS_MOVE            8192)
+(define MS_RELATIME     2097152)
 (define MS_STRICTATIME 16777216)
 (define MS_LAZYTIME    33554432)
 
@@ -519,17 +532,106 @@ constants from <sys/mount.h>."
       (when update-mtab?
         (remove-from-mtab target)))))
 
-(define (mount-points)
-  "Return the mounts points for currently mounted file systems."
-  (call-with-input-file "/proc/mounts"
+;; Mount point information.
+(define-record-type <mount>
+  (%mount source point devno type options)
+  mount?
+  (devno    mount-device-number)                  ;st_dev
+  (source   mount-source)                         ;string
+  (point    mount-point)                          ;string
+  (type     mount-type)                           ;string
+  (options  mount-options))                       ;string
+
+(define (option-string->mount-flags str)
+  "Parse the \"option string\" STR as it appears in /proc/mounts and similar,
+and return two values: a mount bitmask (inclusive or of MS_* constants), and
+the remaining unprocessed options."
+  ;; Why do we need to do this?  Because mount flags and mount options are
+  ;; often lumped together; this is the case in /proc/mounts & co., so we need
+  ;; to extract the bits that actually correspond to mount flags.
+
+  (define not-comma
+    (char-set-complement (char-set #\,)))
+
+  (define lst
+    (string-tokenize str not-comma))
+
+  (let loop ((options   lst)
+             (mask      0)
+             (remainder '()))
+    (match options
+      (()
+       (values mask (string-concatenate-reverse remainder)))
+      ((head . tail)
+       (letrec-syntax ((match-options (syntax-rules (=>)
+                                        ((_)
+                                         (loop tail mask
+                                               (cons head remainder)))
+                                        ((_ (str => bit) rest ...)
+                                         (if (string=? str head)
+                                             (loop tail (logior bit mask)
+                                                   remainder)
+                                             (match-options rest ...))))))
+         (match-options ("rw"         => 0)
+                        ("ro"         => MS_RDONLY)
+                        ("nosuid"     => MS_NOSUID)
+                        ("nodev"      => MS_NODEV)
+                        ("noexec"     => MS_NOEXEC)
+                        ("relatime"   => MS_RELATIME)
+                        ("noatime"    => MS_NOATIME)))))))
+
+(define (mount-flags mount)
+  "Return the mount flags of MOUNT, a <mount> record, as an inclusive or of
+MS_* constants."
+  (option-string->mount-flags (mount-options mount)))
+
+(define (octal-decode str)
+  "Decode octal escapes from STR and return the corresponding string.  STR may
+look like this: \"white\\040space\", which is decoded as \"white space\"."
+  (define char-set:octal
+    (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))
+  (define (octal? c)
+    (char-set-contains? char-set:octal c))
+
+  (let loop ((chars (string->list str))
+             (result '()))
+    (match chars
+      (()
+       (list->string (reverse result)))
+      ((#\\ (? octal? a) (? octal? b) (? octal? c) . rest)
+       (loop rest
+             (cons (integer->char
+                    (string->number (list->string (list a b c)) 8))
+                   result)))
+      ((head . tail)
+       (loop tail (cons head result))))))
+
+(define (mounts)
+  "Return the list of mounts (<mount> records) visible in the namespace of the
+current process."
+  (define (string->device-number str)
+    (match (string-split str #\:)
+      (((= string->number major) (= string->number minor))
+       (+ (* major 256) minor))))
+
+  (call-with-input-file "/proc/self/mountinfo"
     (lambda (port)
       (let loop ((result '()))
         (let ((line (read-line port)))
           (if (eof-object? line)
               (reverse result)
               (match (string-tokenize line)
-                ((source mount-point _ ...)
-                 (loop (cons mount-point result))))))))))
+                ((id parent-id major:minor root mount-point
+                     options _ type source _ ...)
+                 (let ((devno (string->device-number major:minor)))
+                   (loop (cons (%mount (octal-decode source)
+                                       (octal-decode mount-point)
+                                       devno type options)
+                               result)))))))))))
+
+(define (mount-points)
+  "Return the mounts points for currently mounted file systems."
+  (map mount-point (mounts)))
 
 (define swapon
   (let ((proc (syscall->procedure int "swapon" (list '* int))))
diff --git a/guix/describe.scm b/guix/describe.scm
index 6a31c707f0..0683ad8a27 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -23,7 +23,9 @@
   #:use-module ((guix utils) #:select (location-file))
   #:use-module ((guix store) #:select (%store-prefix store-path?))
   #:use-module ((guix config) #:select (%state-directory))
-  #:autoload   (guix channels) (sexp->channel manifest-entry-channel)
+  #:autoload   (guix channels) (channel-name
+                                sexp->channel
+                                manifest-entry-channel)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (current-profile
@@ -33,6 +35,7 @@
             package-path-entries
 
             package-provenance
+            package-channels
             manifest-entry-with-provenance
             manifest-entry-provenance))
 
@@ -144,6 +147,26 @@ when applicable."
                                       "/site-ccache")))
                (current-channel-entries))))
 
+(define (package-channels package)
+  "Return the list of channels providing PACKAGE or an empty list if it could
+not be determined."
+  (match (and=> (package-location package) location-file)
+    (#f '())
+    (file
+     (let ((file (if (string-prefix? "/" file)
+                     file
+                     (search-path %load-path file))))
+       (if (and file
+                (string-prefix? (%store-prefix) file))
+           (filter-map
+            (lambda (entry)
+              (let ((item (manifest-entry-item entry)))
+                (and (or (string-prefix? item file)
+                         (string=? "guix" (manifest-entry-name entry)))
+                     (manifest-entry-channel entry))))
+            (current-profile-entries))
+           '())))))
+
 (define (package-provenance package)
   "Return the provenance of PACKAGE as an sexp for use as the 'provenance'
 property of manifest entries, or #f if it could not be determined."
@@ -153,36 +176,31 @@ property of manifest entries, or #f if it could not be determined."
       (('source value) value)
       (_ #f)))
 
-  (match (and=> (package-location package) location-file)
-    (#f #f)
-    (file
-     (let ((file (if (string-prefix? "/" file)
-                     file
-                     (search-path %load-path file))))
-       (and file
-            (string-prefix? (%store-prefix) file)
-
-            ;; Always store information about the 'guix' channel and
-            ;; optionally about the specific channel FILE comes from.
-            (or (let ((main  (and=> (find (lambda (entry)
-                                            (string=? "guix"
-                                                      (manifest-entry-name entry)))
-                                          (current-profile-entries))
-                                    entry-source))
-                      (extra (any (lambda (entry)
-                                    (let ((item (manifest-entry-item entry)))
-                                      (and (string-prefix? item file)
-                                           (entry-source entry))))
-                                  (current-profile-entries))))
-                  (and main
-                       `(,main
-                         ,@(if extra (list extra) '()))))))))))
+  (let* ((channels (package-channels package))
+         (names (map (compose symbol->string channel-name) channels)))
+    ;; Always store information about the 'guix' channel and
+    ;; optionally about the specific channel FILE comes from.
+    (or (let ((main  (and=> (find (lambda (entry)
+                                    (string=? "guix"
+                                              (manifest-entry-name entry)))
+                                  (current-profile-entries))
+                            entry-source))
+              (extra (any (lambda (entry)
+                            (let ((item (manifest-entry-item entry))
+                                  (name (manifest-entry-name entry)))
+                              (and (member name names)
+                                   (not (string=? name "guix"))
+                                   (entry-source entry))))
+                          (current-profile-entries))))
+          (and main
+               `(,main
+                 ,@(if extra (list extra) '())))))))
 
 (define (manifest-entry-with-provenance entry)
   "Return ENTRY with an additional 'provenance' property if it's not already
 there."
   (let ((properties (manifest-entry-properties entry)))
-    (if (assq 'properties properties)
+    (if (assq 'provenance properties)
         entry
         (let ((item (manifest-entry-item entry)))
           (manifest-entry
diff --git a/guix/download.scm b/guix/download.scm
index 494825860e..579996f090 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@@ -535,9 +535,9 @@ own.  This helper makes it easier to deal with \"tar bombs\"."
                         #~(begin
                             (use-modules (guix build utils))
                             (mkdir #$output)
-                            (setenv "PATH" (string-append #$gzip "/bin"))
+                            (setenv "PATH" (string-append #+gzip "/bin"))
                             (chdir #$output)
-                            (invoke (string-append #$tar "/bin/tar")
+                            (invoke (string-append #+tar "/bin/tar")
                                     "xf" #$drv)))
                       #:system system
                       #:guile-for-build guile
@@ -574,7 +574,7 @@ own.  This helper makes it easier to deal with \"zip bombs\"."
                             (use-modules (guix build utils))
                             (mkdir #$output)
                             (chdir #$output)
-                            (invoke (string-append #$unzip "/bin/unzip")
+                            (invoke (string-append #+unzip "/bin/unzip")
                                     #$drv)))
                       #:system system
                       #:guile-for-build guile
diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm
index 8d5adcb8ed..9cc34cc7ec 100644
--- a/guix/ftp-client.scm
+++ b/guix/ftp-client.scm
@@ -216,6 +216,17 @@ TIMEOUT, an ETIMEDOUT error is raised."
           (else
            (throw 'ftp-error conn "PASV" 227 message)))))
 
+(define (ftp-epsv conn)
+  (let* ((message (%ftp-command "EPSV" 229 (ftp-connection-socket conn))))
+    (string->number
+     (match:substring (string-match "\\(...([0-9]+).\\)" message) 1))))
+
+(define (ftp-passive conn)
+  "Enter passive mode using EPSV or PASV, return a data connection port on
+success."
+  ;; IPv6 only works with EPSV, so try it first.
+  (or (false-if-exception (ftp-epsv conn)) (ftp-pasv conn)))
+
 (define (address-with-port sa port)
   "Return a socket-address object based on SA, but with PORT."
   (let ((fam  (sockaddr:fam sa))
@@ -232,7 +243,7 @@ TIMEOUT, an ETIMEDOUT error is raised."
   (if directory
       (ftp-chdir conn directory))
 
-  (let* ((port (ftp-pasv conn))
+  (let* ((port (ftp-passive conn))
          (ai   (ftp-connection-addrinfo conn))
          (s    (socket (addrinfo:fam ai) (addrinfo:socktype ai)
                        (addrinfo:protocol ai))))
@@ -281,7 +292,7 @@ must be closed before CONN can be used for other purposes."
   ;; Ask for "binary mode".
   (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
 
-  (let* ((port (ftp-pasv conn))
+  (let* ((port (ftp-passive conn))
          (ai   (ftp-connection-addrinfo conn))
          (s    (with-fluids ((%default-port-encoding #f))
                  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 2735d25d0c..78ce19956c 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -120,8 +120,6 @@
             file-like?
             lower-object
 
-            lower-inputs
-
             &gexp-error
             gexp-error?
             &gexp-input-error
@@ -759,19 +757,28 @@ attribute that is traversed."
        (append (let ((attribute (self-attribute gexp)))
                  (validate gexp attribute)
                  attribute)
-               (append-map (match-lambda
-                             (($ <gexp-input> (? gexp? exp))
-                              (gexp-attribute exp self-attribute
-                                              #:validate validate))
-                             (($ <gexp-input> (lst ...))
-                              (append-map (lambda (item)
-                                            (gexp-attribute item self-attribute
-                                                            #:validate
-                                                            validate))
-                                          lst))
-                             (_
-                              '()))
-                           (gexp-references gexp)))
+               (reverse
+                (fold (lambda (input result)
+                        (match input
+                          (($ <gexp-input> (? gexp? exp))
+                           (append (gexp-attribute exp self-attribute
+                                                   #:validate validate)
+                                   result))
+                          (($ <gexp-input> (lst ...))
+                           (fold/tree (lambda (obj result)
+                                        (match obj
+                                          ((? gexp? exp)
+                                           (append (gexp-attribute exp self-attribute
+                                                                   #:validate validate)
+                                                   result))
+                                          (_
+                                           result)))
+                                      result
+                                      lst))
+                          (_
+                           result)))
+                      '()
+                      (gexp-references gexp))))
        equal?)
       '()))                                       ;plain Scheme data type
 
@@ -828,8 +835,7 @@ list."
     (one-of symbol? string? keyword? pair? null? array?
             number? boolean? char?)))
 
-(define* (lower-inputs inputs
-                       #:key system target)
+(define (lower-inputs inputs system target)
   "Turn any object from INPUTS into a derivation input for SYSTEM or a store
 item (a \"source\"); return the corresponding input list as a monadic value.
 When TARGET is true, use it as the cross-compilation target triplet."
@@ -842,24 +848,23 @@ When TARGET is true, use it as the cross-compilation target triplet."
   (with-monad %store-monad
     (>>= (mapm/accumulate-builds
           (match-lambda
-            (((? struct? thing) sub-drv ...)
-             (mlet %store-monad ((obj (lower-object
-                                       thing system #:target target)))
+            (($ <gexp-input> (? store-item? item))
+             (return item))
+            (($ <gexp-input> thing output native?)
+             (mlet %store-monad ((obj (lower-object thing system
+                                                    #:target
+                                                    (and (not native?)
+                                                         target))))
                (return (match obj
                          ((? derivation? drv)
-                          (let ((outputs (if (null? sub-drv)
-                                             '("out")
-                                             sub-drv)))
-                            (derivation-input drv outputs)))
+                          (derivation-input drv (list output)))
                          ((? store-item? item)
                           item)
                          ((? self-quoting?)
                           ;; Some inputs such as <system-binding> can lower to
                           ;; a self-quoting object that FILTERM will filter
                           ;; out.
-                          #f)))))
-            (((? store-item? item))
-             (return item)))
+                          #f))))))
           inputs)
          filterm)))
 
@@ -867,11 +872,17 @@ When TARGET is true, use it as the cross-compilation target triplet."
   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
 #:reference-graphs argument, lower it such that each INPUT is replaced by the
 corresponding <derivation-input> or store item."
+  (define tuple->gexp-input
+    (match-lambda
+      ((thing)
+       (%gexp-input thing "out" (not target)))
+      ((thing output)
+       (%gexp-input thing output (not target)))))
+
   (match graphs
     (((file-names . inputs) ...)
-     (mlet %store-monad ((inputs (lower-inputs inputs
-                                               #:system system
-                                               #:target target)))
+     (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs)
+                                               system target)))
        (return (map cons file-names inputs))))))
 
 (define* (lower-references lst #:key system target)
@@ -941,6 +952,15 @@ second element is the derivation to compile them."
            modules
            system extensions guile deprecation-warnings module-path))
 
+(define (sexp->string sexp)
+  "Like 'object->string', but deterministic and slightly faster."
+  ;; Explicitly use UTF-8 for determinism, and also because UTF-8 output is
+  ;; faster.
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    (call-with-output-string
+     (lambda (port)
+       (write sexp port)))))
+
 (define* (lower-gexp exp
                      #:key
                      (module-path %load-path)
@@ -991,16 +1011,9 @@ derivations--e.g., code evaluated for its side effects."
                        (guile     (if guile-for-build
                                       (return guile-for-build)
                                       (default-guile-derivation system)))
-                       (normals  (lower-inputs (gexp-inputs exp)
-                                               #:system system
-                                               #:target target))
-                       (natives  (lower-inputs (gexp-native-inputs exp)
-                                               #:system system
-                                               #:target #f))
-                       (inputs -> (append normals natives))
-                       (sexp     (gexp->sexp exp
-                                             #:system system
-                                             #:target target))
+                       (inputs   (lower-inputs (gexp-inputs exp)
+                                               system target))
+                       (sexp     (gexp->sexp exp system target))
                        (extensions -> (gexp-extensions exp))
                        (exts     (mapm %store-monad
                                        (lambda (obj)
@@ -1159,7 +1172,7 @@ The other arguments are as for 'derivation'."
                                        (return #f)))
                        (guile -> (lowered-gexp-guile lowered))
                        (builder  (text-file script-name
-                                            (object->string
+                                            (sexp->string
                                              (lowered-gexp-sexp lowered)))))
     (mbegin %store-monad
       (set-grafting graft?)                       ;restore the initial setting
@@ -1203,42 +1216,60 @@ The other arguments are as for 'derivation'."
                       #:substitutable? substitutable?
                       #:properties properties))))
 
-(define* (gexp-inputs exp #:key native?)
-  "Return the input list for EXP.  When NATIVE? is true, return only native
-references; otherwise, return only non-native references."
-  ;; TODO: Return <gexp-input> records instead of tuples.
+(define (fold/tree proc seed lst)
+  "Like 'fold', but recurse into sub-lists of LST and accept improper lists."
+  (let loop ((obj lst)
+             (result seed))
+    (match obj
+      ((head . tail)
+       (loop tail (loop head result)))
+      (_
+       (proc obj result)))))
+
+(define (gexp-inputs exp)
+  "Return the list of <gexp-input> for EXP."
+  (define set-gexp-input-native?
+    (match-lambda
+      (($ <gexp-input> thing output)
+       (%gexp-input thing output #t))))
+
+  (define (interesting? obj)
+    (or (file-like? obj)
+        (and (string? obj) (direct-store-path? obj))))
+
   (define (add-reference-inputs ref result)
     (match ref
       (($ <gexp-input> (? gexp? exp) _ #t)
-       (if native?
-           (append (gexp-inputs exp)
-                   (gexp-inputs exp #:native? #t)
-                   result)
-           result))
-      (($ <gexp-input> (? gexp? exp) _ #f)
-       (append (gexp-inputs exp #:native? native?)
+       (append (map set-gexp-input-native? (gexp-inputs exp))
                result))
+      (($ <gexp-input> (? gexp? exp) _ #f)
+       (append (gexp-inputs exp) result))
       (($ <gexp-input> (? string? str))
        (if (direct-store-path? str)
-           (cons `(,str) result)
+           (cons ref result)
            result))
       (($ <gexp-input> (? struct? thing) output n?)
-       (if (and (eqv? n? native?) (lookup-compiler thing))
+       (if (lookup-compiler thing)
            ;; THING is a derivation, or a package, or an origin, etc.
-           (cons `(,thing ,output) result)
+           (cons ref result)
            result))
-      (($ <gexp-input> (lst ...) output n?)
-       (fold-right add-reference-inputs result
-                   ;; XXX: For now, automatically convert LST to a list of
-                   ;; gexp-inputs.  Inherit N?.
-                   (map (match-lambda
-                          ((? gexp-input? x)
-                           (%gexp-input (gexp-input-thing x)
-                                        (gexp-input-output x)
-                                        n?))
-                          (x
-                           (%gexp-input x "out" n?)))
-                        lst)))
+      (($ <gexp-input> (? pair? lst) output n?)
+       ;; XXX: Scan LST for inputs.  Inherit N?.
+       (fold/tree (lambda (obj result)
+                    (match obj
+                      ((? gexp-input? x)
+                       (cons (%gexp-input (gexp-input-thing x)
+                                          (gexp-input-output x)
+                                          n?)
+                             result))
+                      ((? interesting? x)
+                       (cons (%gexp-input x "out" n?) result))
+                      ((? gexp? x)
+                       (append (gexp-inputs x) result))
+                      (_
+                       result)))
+                  result
+                  lst))
       (_
        ;; Ignore references to other kinds of objects.
        result)))
@@ -1247,9 +1278,6 @@ references; otherwise, return only non-native references."
               '()
               (gexp-references exp)))
 
-(define gexp-native-inputs
-  (cut gexp-inputs <> #:native? #t))
-
 (define (gexp-outputs exp)
   "Return the outputs referred to by EXP as a list of strings."
   (define (add-reference-output ref result)
@@ -1258,24 +1286,22 @@ references; otherwise, return only non-native references."
        (cons name result))
       (($ <gexp-input> (? gexp? exp))
        (append (gexp-outputs exp) result))
-      (($ <gexp-input> (lst ...) output native?)
-       ;; XXX: Automatically convert LST.
-       (add-reference-output (map (match-lambda
-                                   ((? gexp-input? x) x)
-                                   (x (%gexp-input x "out" native?)))
-                                  lst)
-                             result))
-      ((lst ...)
-       (fold-right add-reference-output result lst))
+      (($ <gexp-input> (? pair? lst))
+       ;; XXX: Scan LST for outputs.
+       (fold/tree (lambda (obj result)
+                    (match obj
+                      (($ <gexp-output> name) (cons name result))
+                      ((? gexp? x) (append (gexp-outputs x) result))
+                      (_ result)))
+                  result
+                  lst))
       (_
        result)))
 
   (delete-duplicates
-   (add-reference-output (gexp-references exp) '())))
+   (fold add-reference-output '() (gexp-references exp))))
 
-(define* (gexp->sexp exp #:key
-                     (system (%current-system))
-                     (target (%current-target-system)))
+(define (gexp->sexp exp system target)
   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
 and in the current monad setting (system type, etc.)"
   (define* (reference->sexp ref #:optional native?)
@@ -1288,17 +1314,19 @@ and in the current monad setting (system type, etc.)"
          (return `((@ (guile) getenv) ,output)))
         (($ <gexp-input> (? gexp? exp) output n?)
          (gexp->sexp exp
-                     #:system system
-                     #:target (if (or n? native?) #f target)))
+                     system (if (or n? native?) #f target)))
         (($ <gexp-input> (refs ...) output n?)
          (mapm %store-monad
                (lambda (ref)
                  ;; XXX: Automatically convert REF to an gexp-input.
-                 (reference->sexp
-                  (if (gexp-input? ref)
-                      ref
-                      (%gexp-input ref "out" n?))
-                  (or n? native?)))
+                 (if (or (symbol? ref) (number? ref)
+                         (boolean? ref) (null? ref) (array? ref))
+                     (return ref)
+                     (reference->sexp
+                      (if (gexp-input? ref)
+                          ref
+                          (%gexp-input ref "out" n?))
+                      (or n? native?))))
                refs))
         (($ <gexp-input> (? struct? thing) output n?)
          (let ((target (if (or n? native?) #f target)))
@@ -1685,6 +1713,7 @@ TARGET, a GNU triplet."
     ;; TODO: Pass MODULES as an environment variable.
     (gexp->derivation name build
                       #:system system
+                      #:target target
                       #:guile-for-build guile
                       #:local-build? #t
                       #:env-vars
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 910dcadc8a..fd8a108092 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -323,14 +323,14 @@ DRV, and graft DRV itself to refer to those grafted dependencies."
   ;; Whether to honor package grafts by default.
   (make-parameter #t))
 
-(define (set-grafting enable?)
-  "This monadic procedure enables grafting when ENABLE? is true, and disables
-it otherwise.  It returns the previous setting."
+(define-inlinable (set-grafting enable?)
+  ;; This monadic procedure enables grafting when ENABLE? is true, and
+  ;; disables it otherwise.  It returns the previous setting.
   (lambda (store)
     (values (%graft? enable?) store)))
 
-(define (grafting?)
-  "Return a Boolean indicating whether grafting is enabled."
+(define-inlinable (grafting?)
+  ;; Return a Boolean indicating whether grafting is enabled.
   (lambda (store)
     (values (%graft?) store)))
 
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 553640fe9e..2d7458a56e 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -21,8 +21,11 @@
 
 (define-module (guix http-client)
   #:use-module (web uri)
+  #:use-module (web http)
   #:use-module ((web client) #:hide (open-socket-for-uri))
+  #:use-module (web request)
   #:use-module (web response)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -35,6 +38,7 @@
   #:use-module (guix utils)
   #:use-module (guix base64)
   #:autoload   (gcrypt hash) (sha256)
+  #:autoload   (gnutls) (error/invalid-session)
   #:use-module ((guix build utils)
                 #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
@@ -50,6 +54,7 @@
             http-get-error-reason
 
             http-fetch
+            http-multiple-get
 
             %http-cache-ttl
             http-fetch/cached))
@@ -70,6 +75,7 @@
 
 
 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
+                     (open-connection guix:open-connection-for-uri)
                      (keep-alive? #f)
                      (verify-certificate? #t)
                      (headers '((user-agent . "GNU Guile")))
@@ -92,10 +98,10 @@ Raise an '&http-get-error' condition if downloading fails."
   (let loop ((uri (if (string? uri)
                       (string->uri uri)
                       uri)))
-    (let ((port (or port (guix:open-connection-for-uri uri
-                                                       #:verify-certificate?
-                                                       verify-certificate?
-                                                       #:timeout timeout)))
+    (let ((port (or port (open-connection uri
+                                          #:verify-certificate?
+                                          verify-certificate?
+                                          #:timeout timeout)))
           (headers (match (uri-userinfo uri)
                      ((? string? str)
                       (cons (cons 'Authorization
@@ -138,6 +144,115 @@ Raise an '&http-get-error' condition if downloading fails."
                                 (uri->string uri) code
                                 (response-reason-phrase resp))))))))))))
 
+(define* (http-multiple-get base-uri proc seed requests
+                            #:key port (verify-certificate? #t)
+                            (open-connection guix:open-connection-for-uri)
+                            (keep-alive? #t)
+                            (batch-size 1000))
+  "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
+response, passing it the request object, the response, a port from which to
+read the response body, and the previous result, starting with SEED, à la
+'fold'.  Return the final result.
+
+When PORT is specified, use it as the initial connection on which HTTP
+requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
+a URI.  When KEEP-ALIVE? is false, close the connection port before
+returning."
+  (let connect ((port     port)
+                (requests requests)
+                (result   seed))
+    (define batch
+      (if (>= batch-size (length requests))
+          requests
+          (take requests batch-size)))
+
+    ;; (format (current-error-port) "connecting (~a requests left)..."
+    ;;         (length requests))
+    (let ((p (or port (open-connection base-uri
+                                       #:verify-certificate?
+                                       verify-certificate?))))
+      ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
+      (when (file-port? p)
+        (setvbuf p 'block (expt 2 16)))
+
+      ;; Send BATCH in a row.
+      ;; XXX: Do our own caching to work around inefficiencies when
+      ;; communicating over TLS: <http://bugs.gnu.org/22966>.
+      (let-values (((buffer get) (open-bytevector-output-port)))
+        ;; Inherit the HTTP proxying property from P.
+        (set-http-proxy-port?! buffer (http-proxy-port? p))
+
+        (catch #t
+          (lambda ()
+            (for-each (cut write-request <> buffer)
+                      batch)
+            (put-bytevector p (get))
+            (force-output p))
+          (lambda (key . args)
+            ;; If PORT becomes unusable, open a fresh connection and
+            ;; retry.
+            (if (or (and (eq? key 'system-error)
+                         (= EPIPE (system-error-errno `(,key ,@args))))
+                    (and (eq? key 'gnutls-error)
+                         (eq? (first args) error/invalid-session)))
+                (begin
+                  (close-port p)    ; close the broken port
+                  (connect #f
+                           requests
+                           result))
+                (apply throw key args)))))
+
+      ;; Now start processing responses.
+      (let loop ((sent      batch)
+                 (processed 0)
+                 (result    result))
+        (match sent
+          (()
+           (match (drop requests processed)
+             (()
+              (unless keep-alive?
+                (close-port p))
+              (reverse result))
+             (remainder
+              (connect p remainder result))))
+          ((head tail ...)
+           (catch #t
+             (lambda ()
+               (let* ((resp   (read-response p))
+                      (body   (response-body-port resp))
+                      (result (proc head resp body result)))
+                 ;; The server can choose to stop responding at any time,
+                 ;; in which case we have to try again.  Check whether
+                 ;; that is the case.  Note that even upon "Connection:
+                 ;; close", we can read from BODY.
+                 (match (assq 'connection (response-headers resp))
+                   (('connection 'close)
+                    (close-port p)
+                    (connect #f                       ;try again
+                             (drop requests (+ 1 processed))
+                             result))
+                   (_
+                    (loop tail (+ 1 processed) result))))) ;keep going
+             (lambda (key . args)
+               ;; If PORT was cached and the server closed the connection
+               ;; in the meantime, we get EPIPE.  In that case, open a
+               ;; fresh connection and retry.  We might also get
+               ;; 'bad-response or a similar exception from (web response)
+               ;; later on, once we've sent the request, or a
+               ;; ERROR/INVALID-SESSION from GnuTLS.
+               (if (or (and (eq? key 'system-error)
+                            (= EPIPE (system-error-errno `(,key ,@args))))
+                       (and (eq? key 'gnutls-error)
+                            (eq? (first args) error/invalid-session))
+                       (memq key
+                             '(bad-response bad-header bad-header-component)))
+                   (begin
+                     (close-port p)
+                     (connect #f      ; try again
+                              (drop requests (+ 1 processed))
+                              result))
+                   (apply throw key args))))))))))
+
 
 ;;;
 ;;; Caching.
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index e8caf080fd..dbc858cb84 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -361,7 +361,7 @@ empty list when the FIELD cannot be found."
 
 (define (directory-needs-fortran? dir)
   "Check if the directory DIR contains Fortran source files."
-  (match (find-files dir "\\.f(90|95)?")
+  (match (find-files dir "\\.f(90|95)$")
     (() #f)
     (_ #t)))
 
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index aee1b01c9f..287ffd2536 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -192,9 +193,7 @@ and LICENSE."
                                               (maybe-cargo-inputs cargo-inputs)
                                               (maybe-cargo-development-inputs
                                                 cargo-development-inputs)))
-                   (home-page ,(match home-page
-                                 ('null "")
-                                 (_ home-page)))
+                   (home-page ,home-page)
                    (synopsis ,synopsis)
                    (description ,(beautify-description description))
                    (license ,(match license
@@ -304,8 +303,14 @@ look up the development dependencs for the given crate."
                            #:version (crate-version-number version*)
                            #:cargo-inputs cargo-inputs
                            #:cargo-development-inputs cargo-development-inputs
-                           #:home-page (or (crate-home-page crate)
-                                           (crate-repository crate))
+                           #:home-page
+                           (let ((home-page (crate-home-page crate)))
+                             (if (string? home-page)
+                                 home-page
+                                 (let ((repository (crate-repository crate)))
+                                   (if (string? repository)
+                                       repository
+                                       ""))))
                            #:synopsis (crate-description crate)
                            #:description (crate-description crate)
                            #:license (and=> (crate-version-license version*)
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 6ca4f65cb0..9f992ffe8e 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -344,8 +344,8 @@ respectively."
   (memoize hackage->guix-package))
 
 (define* (hackage-recursive-import package-name . args)
-  (recursive-import package-name #f
-                    #:repo->guix-package (lambda (name repo)
+  (recursive-import package-name
+                    #:repo->guix-package (lambda* (name #:key repo version)
                                            (apply hackage->guix-package/m
                                                   (cons name args)))
                     #:guix-name hackage-name->package-name))
diff --git a/guix/narinfo.scm b/guix/narinfo.scm
index d3deba28bd..2d06124017 100644
--- a/guix/narinfo.scm
+++ b/guix/narinfo.scm
@@ -25,7 +25,6 @@
   #:use-module (guix base64)
   #:use-module (guix records)
   #:use-module (guix diagnostics)
-  #:use-module (guix scripts substitute)
   #:use-module (gcrypt hash)
   #:use-module (gcrypt pk-crypto)
   #:use-module (rnrs bytevectors)
diff --git a/guix/openpgp.scm b/guix/openpgp.scm
index 648c359621..9de7feb644 100644
--- a/guix/openpgp.scm
+++ b/guix/openpgp.scm
@@ -538,17 +538,6 @@ signature."
            (raise (condition
                    (&openpgp-invalid-signature-error (port port))))))))
 
-(define (hash-algorithm-name algorithm)        ;XXX: should be in Guile-Gcrypt
-  "Return the name of ALGORITHM, a 'hash-algorithm' integer, as a symbol."
-  (letrec-syntax ((->name (syntax-rules ()
-                            ((_) #f)
-                            ((_ name rest ...)
-                             (if (= algorithm (hash-algorithm name))
-                                 'name
-                                 (->name rest ...))))))
-    (->name sha1 sha256 sha384 sha512 sha224
-            sha3-224 sha3-256 sha3-384 sha3-512)))
-
 (define (verify-openpgp-signature sig keyring dataport)
   "Verify that the data read from DATAPORT matches SIG, an
 <openpgp-signature>.  Fetch the public key of the issuer of SIG from KEYRING,
diff --git a/guix/packages.scm b/guix/packages.scm
index 67ef6ea146..2dbcc7ba8b 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -428,7 +428,7 @@ name of its URI."
 
 (define-syntax-rule (package/inherit p overrides ...)
   "Like (package (inherit P) OVERRIDES ...), except that the same
-transformation is done to the package replacement, if any.  P must be a bare
+transformation is done to the package P's replacement, if any.  P must be a bare
 identifier, and will be bound to either P or its replacement when evaluating
 OVERRIDES."
   (let loop ((p p))
@@ -478,29 +478,34 @@ object."
 
   (match (package-location package)
     (($ <location> file line column)
-     (catch 'system-error
-       (lambda ()
-         ;; In general we want to keep relative file names for modules.
-         (call-with-input-file (search-path %load-path file)
-           (lambda (port)
-             (goto port line column)
-             (match (read port)
-               (('package inits ...)
-                (let ((field (assoc field inits)))
-                  (match field
-                    ((_ value)
-                     (let ((loc (and=> (source-properties value)
-                                       source-properties->location)))
-                       (and loc
-                            ;; Preserve the original file name, which may be a
-                            ;; relative file name.
-                            (set-field loc (location-file) file))))
-                    (_
-                     #f))))
-               (_
-                #f)))))
-       (lambda _
-         #f)))
+     (match (search-path %load-path file)
+       ((? string? file-found)
+        (catch 'system-error
+          (lambda ()
+            ;; In general we want to keep relative file names for modules.
+            (call-with-input-file file-found
+              (lambda (port)
+                (goto port line column)
+                (match (read port)
+                  (('package inits ...)
+                   (let ((field (assoc field inits)))
+                     (match field
+                       ((_ value)
+                        (let ((loc (and=> (source-properties value)
+                                          source-properties->location)))
+                          (and loc
+                               ;; Preserve the original file name, which may be a
+                               ;; relative file name.
+                               (set-field loc (location-file) file))))
+                       (_
+                        #f))))
+                  (_
+                   #f)))))
+          (lambda _
+            #f)))
+       (#f
+        ;; FILE could not be found in %LOAD-PATH.
+        #f)))
     (_ #f)))
 
 
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 36cb30c191..7a207589b0 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -362,9 +362,16 @@ file name."
            #t
            lst)))
 
+(define (default-properties package)
+  "Return the default properties of a manifest entry for PACKAGE."
+  ;; Preserve transformation options by default.
+  (match (assq-ref (package-properties package) 'transformations)
+    (#f '())
+    (transformations `((transformations . ,transformations)))))
+
 (define* (package->manifest-entry package #:optional (output "out")
                                   #:key (parent (delay #f))
-                                  (properties '()))
+                                  (properties (default-properties package)))
   "Return a manifest entry for the OUTPUT of package PACKAGE."
   ;; For each dependency, keep a promise pointing to its "parent" entry.
   (letrec* ((deps  (map (match-lambda
diff --git a/guix/scripts.scm b/guix/scripts.scm
index c9ea9f2e29..3aabaf5c9c 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
@@ -118,7 +118,12 @@ procedure, but both the category and synopsis are meant to be read (parsed) by
 according to'string-distance'."
   (define (options->long-names options)
     (filter string? (append-map option-names options)))
-  (string-closest guess (options->long-names options) #:threshold 3))
+  (match guess
+    ((? string?)
+     (match (string-split guess #\=)
+       ((name rest ...)
+        (string-closest name (options->long-names options) #:threshold 3))))
+    (_ #f)))
 
 (define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
   "A wrapper on top of `args-fold' that does proper user-facing error
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index cc9cbe6f27..4ec3be99ca 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -27,7 +27,7 @@
   #:use-module (guix packages)
   #:use-module ((guix progress) #:hide (dump-port*))
   #:use-module (guix serialization)
-  #:use-module (guix scripts substitute)
+  #:use-module (guix substitutes)
   #:use-module (guix narinfo)
   #:use-module (rnrs bytevectors)
   #:autoload   (guix http-client) (http-fetch)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index a39347743e..0360761683 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -745,14 +745,15 @@ message if any test fails."
           (with-status-verbosity (assoc-ref opts 'verbosity)
             (define manifest-from-opts
               (options/resolve-packages store opts))
-            (when (and profile
-                       (> (length (manifest-entries manifest-from-opts)) 0))
-              (leave (G_ "'--profile' cannot be used with package options~%")))
 
             (define manifest
               (if profile
-                (profile-manifest profile)
-                manifest-from-opts))
+                  (profile-manifest profile)
+                  manifest-from-opts))
+
+            (when (and profile
+                       (> (length (manifest-entries manifest-from-opts)) 0))
+              (leave (G_ "'--profile' cannot be used with package options~%")))
 
             (set-build-options-from-command-line store opts)
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 169cbc2500..d12fbaff6a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
@@ -1179,24 +1179,19 @@ Create a bundle of PACKAGE.\n"))
                manifest))
             identity))
 
-      (define (with-transformations manifest)
-        (map-manifest-entries manifest-entry-with-transformations
-                              manifest))
-
       (with-provenance
-       (with-transformations
-        (cond
-         ((and (not (null? manifests)) (not (null? packages)))
-          (leave (G_ "both a manifest and a package list were given~%")))
-         ((not (null? manifests))
-          (concatenate-manifests
-           (map (lambda (file)
-                  (let ((user-module (make-user-module
-                                      '((guix profiles) (gnu)))))
-                    (load* file user-module)))
-                manifests)))
-         (else
-          (packages->manifest packages)))))))
+       (cond
+        ((and (not (null? manifests)) (not (null? packages)))
+         (leave (G_ "both a manifest and a package list were given~%")))
+        ((not (null? manifests))
+         (concatenate-manifests
+          (map (lambda (file)
+                 (let ((user-module (make-user-module
+                                     '((guix profiles) (gnu)))))
+                   (load* file user-module)))
+               manifests)))
+        (else
+         (packages->manifest packages))))))
 
   (with-error-handling
     (with-store store
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 8234a1703d..fc5bf8137b 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -235,14 +235,12 @@ non-zero relevance score."
                (case (version-compare candidate-version version)
                  ((>)
                   (manifest-transaction-install-entry
-                   (manifest-entry-with-transformations
-                    (package->manifest-entry* pkg output))
+                   (package->manifest-entry* pkg output)
                    transaction))
                  ((<)
                   transaction)
                  ((=)
-                  (let* ((new (manifest-entry-with-transformations
-                               (package->manifest-entry* pkg output))))
+                  (let* ((new (package->manifest-entry* pkg output)))
                     ;; Here we want to determine whether the NEW actually
                     ;; differs from ENTRY, but we need to intercept
                     ;; 'build-things' calls because they would prevent us from
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 4e0ab5d341..07613240a8 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
-;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,7 +39,7 @@
                                 close-inferior)
   #:use-module (guix scripts build)
   #:use-module (guix scripts describe)
-  #:autoload   (guix build utils) (which)
+  #:autoload   (guix build utils) (which mkdir-p)
   #:use-module ((guix build syscalls)
                 #:select (with-file-lock/no-wait))
   #:use-module (guix git)
@@ -91,11 +91,11 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
   -C, --channels=FILE    deploy the channels defined in FILE"))
   (display (G_ "
-      --url=URL          download from the Git repository at URL"))
+      --url=URL          download \"guix\" channel from the Git repository at URL"))
   (display (G_ "
-      --commit=COMMIT    download the specified COMMIT"))
+      --commit=COMMIT    download the specified \"guix\" channel COMMIT"))
   (display (G_ "
-      --branch=BRANCH    download the tip of the specified BRANCH"))
+      --branch=BRANCH    download the tip of the specified \"guix\" channel BRANCH"))
   (display (G_ "
       --allow-downgrades allow downgrades to earlier channel revisions"))
   (display (G_ "
@@ -521,6 +521,7 @@ true, display what would be built without actually building it."
       (catch 'system-error
         (lambda ()
           (false-if-exception (delete-file link))
+          (mkdir-p (dirname link))
           (symlink %current-profile link))
         (lambda args
           (leave (G_ "while creating symlink '~a': ~a~%")
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index f9bcead045..5866b8bb0a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
@@ -24,6 +24,7 @@
   #:use-module (guix scripts)
   #:use-module (guix narinfo)
   #:use-module (guix store)
+  #:use-module (guix substitutes)
   #:use-module (guix utils)
   #:use-module (guix combinators)
   #:use-module (guix config)
@@ -39,40 +40,28 @@
   #:use-module (guix cache)
   #:use-module (gcrypt pk-crypto)
   #:use-module (guix pki)
-  #:use-module ((guix build utils) #:select (mkdir-p dump-port))
+  #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module ((guix build download)
                 #:select (uri-abbreviation nar-uri-abbreviation
                           (open-connection-for-uri
-                           . guix:open-connection-for-uri)
-                          store-path-abbreviation byte-count->string))
-  #:autoload   (gnutls) (error/invalid-session)
+                           . guix:open-connection-for-uri)))
   #:use-module (guix progress)
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 ftw)
-  #:use-module (ice-9 binary-ports)
-  #:use-module (ice-9 vlist)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (web uri)
-  #:use-module (web http)
-  #:use-module (web request)
-  #:use-module (web response)
   #:use-module (guix http-client)
-  #:export (lookup-narinfos
-            lookup-narinfos/diverse
-
-            %allow-unauthenticated-substitutes?
+  #:export (%allow-unauthenticated-substitutes?
             %error-to-file-descriptor-4?
 
             substitute-urls
@@ -89,16 +78,9 @@
 ;;;
 ;;; Code:
 
-(define %narinfo-cache-directory
-  ;; A local cache of narinfos, to avoid going to the network.  Most of the
-  ;; time, 'guix substitute' is called by guix-daemon as root and stores its
-  ;; cached data in /var/guix/….  However, when invoked from 'guix challenge'
-  ;; as a user, it stores its cache in ~/.cache.
-  (if (zero? (getuid))
-      (or (and=> (getenv "XDG_CACHE_HOME")
-                 (cut string-append <> "/guix/substitute"))
-          (string-append %state-directory "/substitute/cache"))
-      (string-append (cache-directory #:ensure? #f) "/substitute")))
+(define %narinfo-expired-cache-entry-removal-delay
+  ;; How often we want to remove files corresponding to expired cache entries.
+  (* 7 24 3600))
 
 (define (warn-about-missing-authentication)
   (warning (G_ "authentication and authorization of substitutes \
@@ -112,24 +94,6 @@ disabled!~%"))
    (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
           (cut string-ci=? <> "yes"))))
 
-(define %narinfo-ttl
-  ;; Number of seconds during which cached narinfo lookups are considered
-  ;; valid for substitute servers that do not advertise a TTL via the
-  ;; 'Cache-Control' response header.
-  (* 36 3600))
-
-(define %narinfo-negative-ttl
-  ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
-  (* 1 3600))
-
-(define %narinfo-transient-error-ttl
-  ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
-  (* 10 60))
-
-(define %narinfo-expired-cache-entry-removal-delay
-  ;; How often we want to remove files corresponding to expired cache entries.
-  (* 7 24 3600))
-
 (define %fetch-timeout
   ;; Number of seconds after which networking is considered "slow".
   5)
@@ -169,128 +133,6 @@ again."
         (sigaction SIGALRM SIG_DFL)
         (apply values result)))))
 
-(define* (fetch uri #:key (buffered? #t) (timeout? #t)
-                (keep-alive? #f) (port #f))
-  "Return a binary input port to URI and the number of bytes it's expected to
-provide.
-
-When PORT is true, use it as the underlying I/O port for HTTP transfers; when
-PORT is false, open a new connection for URI.  When KEEP-ALIVE? is true, the
-connection (typically PORT) is kept open once data has been fetched from URI."
-  (case (uri-scheme uri)
-    ((file)
-     (let ((port (open-file (uri-path uri)
-                            (if buffered? "rb" "r0b"))))
-       (values port (stat:size (stat port)))))
-    ((http https)
-     (guard (c ((http-get-error? c)
-                (leave (G_ "download from '~a' failed: ~a, ~s~%")
-                       (uri->string (http-get-error-uri c))
-                       (http-get-error-code c)
-                       (http-get-error-reason c))))
-       ;; Test this with:
-       ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
-       ;; and then cancel with:
-       ;;   sudo tc qdisc del dev eth0 root
-       (let ((port port))
-         (with-timeout (if timeout?
-                           %fetch-timeout
-                           0)
-           (begin
-             (warning (G_ "while fetching ~a: server is somewhat slow~%")
-                      (uri->string uri))
-             (warning (G_ "try `--no-substitutes' if the problem persists~%")))
-           (begin
-             (when (or (not port) (port-closed? port))
-               (set! port (guix:open-connection-for-uri
-                           uri #:verify-certificate? #f)))
-             (unless (or buffered? (not (file-port? port)))
-               (setvbuf port 'none))
-             (http-fetch uri #:text? #f #:port port
-                         #:keep-alive? keep-alive?
-                         #:verify-certificate? #f))))))
-    (else
-     (leave (G_ "unsupported substitute URI scheme: ~a~%")
-            (uri->string uri)))))
-
-(define (narinfo-cache-file cache-url path)
-  "Return the name of the local file that contains an entry for PATH.  The
-entry is stored in a sub-directory specific to CACHE-URL."
-  ;; The daemon does not sanitize its input, so PATH could be something like
-  ;; "/gnu/store/foo".  Gracefully handle that.
-  (match (store-path-hash-part path)
-    (#f
-     (leave (G_ "'~a' does not name a store item~%") path))
-    ((? string? hash-part)
-     (string-append %narinfo-cache-directory "/"
-                    (bytevector->base32-string (sha256 (string->utf8 cache-url)))
-                    "/" hash-part))))
-
-(define (cached-narinfo cache-url path)
-  "Check locally if we have valid info about PATH coming from CACHE-URL.
-Return two values: a Boolean indicating whether we have valid cached info, and
-that info, which may be either #f (when PATH is unavailable) or the narinfo
-for PATH."
-  (define now
-    (current-time time-monotonic))
-
-  (define cache-file
-    (narinfo-cache-file cache-url path))
-
-  (catch 'system-error
-    (lambda ()
-      (call-with-input-file cache-file
-        (lambda (p)
-          (match (read p)
-            (('narinfo ('version 2)
-                       ('cache-uri cache-uri)
-                       ('date date) ('ttl ttl) ('value #f))
-             ;; A cached negative lookup.
-             (if (obsolete? date now ttl)
-                 (values #f #f)
-                 (values #t #f)))
-            (('narinfo ('version 2)
-                       ('cache-uri cache-uri)
-                       ('date date) ('ttl ttl) ('value value))
-             ;; A cached positive lookup
-             (if (obsolete? date now ttl)
-                 (values #f #f)
-                 (values #t (string->narinfo value cache-uri))))
-            (('narinfo ('version v) _ ...)
-             (values #f #f))))))
-    (lambda _
-      (values #f #f))))
-
-(define (cache-narinfo! cache-url path narinfo ttl)
-  "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
-given TTL (a number of seconds or #f).  NARINFO may be #f, in which case it
-indicates that PATH is unavailable at CACHE-URL."
-  (define now
-    (current-time time-monotonic))
-
-  (define (cache-entry cache-uri narinfo)
-    `(narinfo (version 2)
-              (cache-uri ,cache-uri)
-              (date ,(time-second now))
-              (ttl ,(or ttl
-                        (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
-              (value ,(and=> narinfo narinfo->string))))
-
-  (let ((file (narinfo-cache-file cache-url path)))
-    (mkdir-p (dirname file))
-    (with-atomic-file-output file
-      (lambda (out)
-        (write (cache-entry cache-url narinfo) out))))
-
-  narinfo)
-
-(define (narinfo-request cache-url path)
-  "Return an HTTP request for the narinfo of PATH at CACHE-URL."
-  (let ((url (string-append cache-url "/" (store-path-hash-part path)
-                            ".narinfo"))
-        (headers '((User-Agent . "GNU Guile"))))
-    (build-request (string->uri url) #:method 'GET #:headers headers)))
-
 (define (at-most max-length lst)
   "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
 return its MAX-LENGTH first elements and its tail."
@@ -305,80 +147,6 @@ return its MAX-LENGTH first elements and its tail."
            (values (reverse result) lst)
            (loop (+ 1 len) tail (cons head result)))))))
 
-(define* (http-multiple-get base-uri proc seed requests
-                            #:key port (verify-certificate? #t)
-                            (open-connection guix:open-connection-for-uri)
-                            (keep-alive? #t)
-                            (batch-size 1000))
-  "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
-response, passing it the request object, the response, a port from which to
-read the response body, and the previous result, starting with SEED, à la
-'fold'.  Return the final result.
-
-When PORT is specified, use it as the initial connection on which HTTP
-requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
-a URI.  When KEEP-ALIVE? is false, close the connection port before
-returning."
-  (let connect ((port     port)
-                (requests requests)
-                (result   seed))
-    (define batch
-      (at-most batch-size requests))
-
-    ;; (format (current-error-port) "connecting (~a requests left)..."
-    ;;         (length requests))
-    (let ((p (or port (open-connection base-uri
-                                       #:verify-certificate?
-                                       verify-certificate?))))
-      ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
-      (when (file-port? p)
-        (setvbuf p 'block (expt 2 16)))
-
-      ;; Send BATCH in a row.
-      ;; XXX: Do our own caching to work around inefficiencies when
-      ;; communicating over TLS: <http://bugs.gnu.org/22966>.
-      (let-values (((buffer get) (open-bytevector-output-port)))
-        ;; Inherit the HTTP proxying property from P.
-        (set-http-proxy-port?! buffer (http-proxy-port? p))
-
-        (for-each (cut write-request <> buffer)
-                  batch)
-        (put-bytevector p (get))
-        (force-output p))
-
-      ;; Now start processing responses.
-      (let loop ((sent      batch)
-                 (processed 0)
-                 (result    result))
-        (match sent
-          (()
-           (match (drop requests processed)
-             (()
-              (unless keep-alive?
-                (close-port p))
-              (reverse result))
-             (remainder
-              (connect p remainder result))))
-          ((head tail ...)
-           (let* ((resp   (read-response p))
-                  (body   (response-body-port resp))
-                  (result (proc head resp body result)))
-             ;; The server can choose to stop responding at any time, in which
-             ;; case we have to try again.  Check whether that is the case.
-             ;; Note that even upon "Connection: close", we can read from BODY.
-             (match (assq 'connection (response-headers resp))
-               (('connection 'close)
-                (close-port p)
-                (connect #f                       ;try again
-                         (drop requests (+ 1 processed))
-                         result))
-               (_
-                (loop tail (+ 1 processed) result)))))))))) ;keep going
-
-(define (read-to-eof port)
-  "Read from PORT until EOF is reached.  The data are discarded."
-  (dump-port port (%make-void-port "w")))
-
 (define (narinfo-from-file file url)
   "Attempt to read a narinfo from FILE, using URL as the cache URL.  Return #f
 if file doesn't exist, and the narinfo otherwise."
@@ -391,191 +159,6 @@ if file doesn't exist, and the narinfo otherwise."
           #f
           (apply throw args)))))
 
-(define %unreachable-hosts
-  ;; Set of names of unreachable hosts.
-  (make-hash-table))
-
-(define* (open-connection-for-uri/maybe uri
-                                        #:key
-                                        fresh?
-                                        (time %fetch-timeout))
-  "Open a connection to URI via 'open-connection-for-uri/cached' and return a
-port to it, or, if connection failed, print a warning and return #f.  Pass
-#:fresh? to 'open-connection-for-uri/cached'."
-  (define host
-    (uri-host uri))
-
-  (catch #t
-    (lambda ()
-      (open-connection-for-uri/cached uri #:timeout time
-                                      #:fresh? fresh?))
-    (match-lambda*
-      (('getaddrinfo-error error)
-       (unless (hash-ref %unreachable-hosts host)
-         (hash-set! %unreachable-hosts host #t)   ;warn only once
-         (warning (G_ "~a: host not found: ~a~%")
-                  host (gai-strerror error)))
-       #f)
-      (('system-error . args)
-       (unless (hash-ref %unreachable-hosts host)
-         (hash-set! %unreachable-hosts host #t)
-         (warning (G_ "~a: connection failed: ~a~%") host
-                  (strerror
-                   (system-error-errno `(system-error ,@args)))))
-       #f)
-      (args
-       (apply throw args)))))
-
-(define (fetch-narinfos url paths)
-  "Retrieve all the narinfos for PATHS from the cache at URL and return them."
-  (define update-progress!
-    (let ((done 0)
-          (total (length paths)))
-      (lambda ()
-        (display "\r\x1b[K" (current-error-port)) ;erase current line
-        (force-output (current-error-port))
-        (format (current-error-port)
-                (G_ "updating substitutes from '~a'... ~5,1f%")
-                url (* 100. (/ done total)))
-        (set! done (+ 1 done)))))
-
-  (define hash-part->path
-    (let ((mapping (fold (lambda (path result)
-                           (vhash-cons (store-path-hash-part path) path
-                                       result))
-                         vlist-null
-                         paths)))
-      (lambda (hash)
-        (match (vhash-assoc hash mapping)
-          (#f #f)
-          ((_ . path) path)))))
-
-  (define (handle-narinfo-response request response port result)
-    (let* ((code   (response-code response))
-           (len    (response-content-length response))
-           (cache  (response-cache-control response))
-           (ttl    (and cache (assoc-ref cache 'max-age))))
-      (update-progress!)
-
-      ;; Make sure to read no more than LEN bytes since subsequent bytes may
-      ;; belong to the next response.
-      (if (= code 200)                            ; hit
-          (let ((narinfo (read-narinfo port url #:size len)))
-            (if (string=? (dirname (narinfo-path narinfo))
-                          (%store-prefix))
-                (begin
-                  (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
-                  (cons narinfo result))
-                result))
-          (let* ((path      (uri-path (request-uri request)))
-                 (hash-part (basename
-                             (string-drop-right path 8)))) ;drop ".narinfo"
-            (if len
-                (get-bytevector-n port len)
-                (read-to-eof port))
-            (cache-narinfo! url (hash-part->path hash-part) #f
-                            (if (or (= 404 code) (= 202 code))
-                                ttl
-                                %narinfo-transient-error-ttl))
-            result))))
-
-  (define (do-fetch uri)
-    (case (and=> uri uri-scheme)
-      ((http https)
-       ;; Note: Do not check HTTPS server certificates to avoid depending
-       ;; on the X.509 PKI.  We can do it because we authenticate
-       ;; narinfos, which provides a much stronger guarantee.
-       (let* ((requests (map (cut narinfo-request url <>) paths))
-              (result   (call-with-cached-connection uri
-                          (lambda (port)
-                            (if port
-                                (begin
-                                  (update-progress!)
-                                  (http-multiple-get uri
-                                                     handle-narinfo-response '()
-                                                     requests
-                                                     #:open-connection
-                                                     open-connection-for-uri/cached
-                                                     #:verify-certificate? #f
-                                                     #:port port))
-                                '()))
-                          open-connection-for-uri/maybe)))
-         (newline (current-error-port))
-         result))
-      ((file #f)
-       (let* ((base  (string-append (uri-path uri) "/"))
-              (files (map (compose (cut string-append base <> ".narinfo")
-                                   store-path-hash-part)
-                          paths)))
-         (filter-map (cut narinfo-from-file <> url) files)))
-      (else
-       (leave (G_ "~s: unsupported server URI scheme~%")
-              (if uri (uri-scheme uri) url)))))
-
-  (do-fetch (string->uri url)))
-
-(define (lookup-narinfos cache paths)
-  "Return the narinfos for PATHS, invoking the server at CACHE when no
-information is available locally."
-  (let-values (((cached missing)
-                (fold2 (lambda (path cached missing)
-                         (let-values (((valid? value)
-                                       (cached-narinfo cache path)))
-                           (if valid?
-                               (if value
-                                   (values (cons value cached) missing)
-                                   (values cached missing))
-                               (values cached (cons path missing)))))
-                       '()
-                       '()
-                       paths)))
-    (if (null? missing)
-        cached
-        (let ((missing (fetch-narinfos cache missing)))
-          (append cached (or missing '()))))))
-
-(define (lookup-narinfos/diverse caches paths authorized?)
-  "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
-That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
-cache, and so on.
-
-Return a list of narinfos for PATHS or a subset thereof.  The returned
-narinfos are either AUTHORIZED?, or they claim a hash that matches an
-AUTHORIZED? narinfo."
-  (define (select-hit result)
-    (lambda (path)
-      (match (vhash-fold* cons '() path result)
-        ((one)
-         one)
-        ((several ..1)
-         (let ((authorized (find authorized? (reverse several))))
-           (and authorized
-                (find (cut equivalent-narinfo? <> authorized)
-                      several)))))))
-
-  (let loop ((caches caches)
-             (paths  paths)
-             (result vlist-null)                  ;path->narinfo vhash
-             (hits   '()))                        ;paths
-    (match paths
-      (()                                         ;we're done
-       ;; Now iterate on all the HITS, and return exactly one match for each
-       ;; hit: the first narinfo that is authorized, or that has the same hash
-       ;; as an authorized narinfo, in the order of CACHES.
-       (filter-map (select-hit result) hits))
-      (_
-       (match caches
-         ((cache rest ...)
-          (let* ((narinfos (lookup-narinfos cache paths))
-                 (definite (map narinfo-path (filter authorized? narinfos)))
-                 (missing  (lset-difference string=? paths definite))) ;XXX: perf
-            (loop rest missing
-                  (fold vhash-cons result
-                        (map narinfo-path narinfos) narinfos)
-                  (append definite hits))))
-         (()                                      ;that's it
-          (filter-map (select-hit result) hits)))))))
-
 (define (lookup-narinfo caches path authorized?)
   "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
 was found."
@@ -629,7 +212,9 @@ was found."
     ;; lookup errors are typically the first one, and because other errors are
     ;; a subset of `system-error', which is harder to filter.
     ((_ exp ...)
-     (catch #t
+     ;; Use a pre-unwind handler so that re-throwing preserves useful
+     ;; backtraces.  'with-throw-handler' works for Guile 2.2 and 3.0.
+     (with-throw-handler #t
        (lambda () exp ...)
        (match-lambda*
          (('getaddrinfo-error error)
@@ -706,14 +291,18 @@ authorized substitutes."
   (match (string-tokenize command)
     (("have" paths ..1)
      ;; Return the subset of PATHS available in CACHE-URLS.
-     (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
+     (let ((substitutable (lookup-narinfos/diverse
+                           cache-urls paths valid?
+                           #:open-connection open-connection-for-uri/cached)))
        (for-each (lambda (narinfo)
                    (format #t "~a~%" (narinfo-path narinfo)))
                  substitutable)
        (newline)))
     (("info" paths ..1)
      ;; Reply info about PATHS if it's in CACHE-URLS.
-     (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
+     (let ((substitutable (lookup-narinfos/diverse
+                           cache-urls paths valid?
+                           #:open-connection open-connection-for-uri/cached)))
        (for-each display-narinfo-data substitutable)
        (newline)))
     (wtf
@@ -726,7 +315,7 @@ authorized substitutes."
 
 (define open-connection-for-uri/cached
   (let ((cache '()))
-    (lambda* (uri #:key fresh? timeout verify-certificate?)
+    (lambda* (uri #:key fresh? (timeout %fetch-timeout) verify-certificate?)
       "Return a connection for URI, possibly reusing a cached connection.
 When FRESH? is true, delete any cached connections for URI and open a new one.
 Return #f if URI's scheme is 'file' or #f.
@@ -769,32 +358,6 @@ server certificates."
                     (drain-input socket)
                     socket))))))))
 
-(define* (call-with-cached-connection uri proc
-                                      #:optional
-                                      (open-connection
-                                       open-connection-for-uri/cached))
-  (let ((port (open-connection uri)))
-    (catch #t
-      (lambda ()
-        (proc port))
-      (lambda (key . args)
-        ;; If PORT was cached and the server closed the connection in the
-        ;; meantime, we get EPIPE.  In that case, open a fresh connection and
-        ;; retry.  We might also get 'bad-response or a similar exception from
-        ;; (web response) later on, once we've sent the request, or a
-        ;; ERROR/INVALID-SESSION from GnuTLS.
-        (if (or (and (eq? key 'system-error)
-                     (= EPIPE (system-error-errno `(,key ,@args))))
-                (and (eq? key 'gnutls-error)
-                     (eq? (first args) error/invalid-session))
-                (memq key '(bad-response bad-header bad-header-component)))
-            (proc (open-connection uri #:fresh? #t))
-            (apply throw key args))))))
-
-(define-syntax-rule (with-cached-connection uri port exp ...)
-  "Bind PORT with EXP... to a socket connected to URI."
-  (call-with-cached-connection uri (lambda (port) exp ...)))
-
 (define* (process-substitution store-item destination
                                #:key cache-urls acl
                                deduplicate? print-build-trace?)
@@ -819,6 +382,38 @@ the current output port."
     (apply dump-file/deduplicate
            (append args (list #:store (%store-prefix)))))
 
+  (define (fetch uri)
+    (case (uri-scheme uri)
+      ((file)
+       (let ((port (open-file (uri-path uri) "r0b")))
+         (values port (stat:size (stat port)))))
+      ((http https)
+       (guard (c ((http-get-error? c)
+                  (leave (G_ "download from '~a' failed: ~a, ~s~%")
+                         (uri->string (http-get-error-uri c))
+                         (http-get-error-code c)
+                         (http-get-error-reason c))))
+         ;; Test this with:
+         ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
+         ;; and then cancel with:
+         ;;   sudo tc qdisc del dev eth0 root
+         (with-timeout %fetch-timeout
+           (begin
+             (warning (G_ "while fetching ~a: server is somewhat slow~%")
+                      (uri->string uri))
+             (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+           (call-with-connection-error-handling
+            uri
+            (lambda ()
+              (http-fetch uri #:text? #f
+                          #:open-connection open-connection-for-uri/cached
+                          #:keep-alive? #t
+                          #:buffered? #f
+                          #:verify-certificate? #f))))))
+      (else
+       (leave (G_ "unsupported substitute URI scheme: ~a~%")
+              (uri->string uri)))))
+
   (unless narinfo
     (leave (G_ "no valid substitute for '~a'~%")
            store-item))
@@ -832,10 +427,7 @@ the current output port."
     (let*-values (((raw download-size)
                    ;; 'guix publish' without '--cache' doesn't specify a
                    ;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
-                   (with-cached-connection uri port
-                     (fetch uri #:buffered? #f #:timeout? #f
-                            #:port port
-                            #:keep-alive? #t)))
+                   (fetch uri))
                   ((progress)
                    (let* ((dl-size  (or download-size
                                         (and (equal? compression "none")
@@ -1006,6 +598,24 @@ default value."
   ;; 'guix-daemon' expects.
   (make-parameter #t))
 
+;; The daemon's agent code opens file descriptor 4 for us and this is where
+;; stderr should go.
+(define-syntax-rule (with-redirected-error-port exp ...)
+  "Evaluate EXP... with the current error port redirected to file descriptor 4
+if needed, as expected by the daemon's agent."
+  (let ((thunk (lambda () exp ...)))
+    (if (%error-to-file-descriptor-4?)
+        (parameterize ((current-error-port (fdopen 4 "wl")))
+          ;; Redirect diagnostics to file descriptor 4 as well.
+          (guix-warning-port (current-error-port))
+
+          ;; 'with-continuation-barrier' captures the initial value of
+          ;; 'current-error-port' to report backtraces in case of uncaught
+          ;; exceptions.  Without it, backtraces would be printed to FD 2,
+          ;; thereby confusing the daemon.
+          (with-continuation-barrier thunk))
+        (thunk))))
+
 (define-command (guix-substitute . args)
   (category internal)
   (synopsis "implement the build daemon's substituter protocol")
@@ -1020,14 +630,7 @@ default value."
   (define deduplicate?
     (find-daemon-option "deduplicate"))
 
-  ;; The daemon's agent code opens file descriptor 4 for us and this is where
-  ;; stderr should go.
-  (parameterize ((current-error-port (if (%error-to-file-descriptor-4?)
-                                         (fdopen 4 "wl")
-                                         (current-error-port))))
-    ;; Redirect diagnostics to file descriptor 4 as well.
-    (guix-warning-port (current-error-port))
-
+  (with-redirected-error-port
     (mkdir-p %narinfo-cache-directory)
     (maybe-remove-expired-cache-entries %narinfo-cache-directory
                                         cached-narinfo-files
@@ -1092,8 +695,7 @@ default value."
 
 ;;; Local Variables:
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
-;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
-;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
+;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0)
 ;;; End:
 
 ;;; substitute.scm ends here
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 19b8c5163c..e3cf99acc6 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -680,13 +680,15 @@ checking this by themselves in their 'check' procedure."
 ;;; Action.
 ;;;
 
-(define* (system-derivation-for-action os action
-                                       #:key image-size image-type
-                                       full-boot? container-shared-network?
-                                       mappings label
-                                       volatile-root?)
-  "Return as a monadic value the derivation for OS according to ACTION."
-  (mlet %store-monad ((target (current-target-system)))
+(define* (system-derivation-for-action image action
+                                       #:key
+                                       full-boot?
+                                       container-shared-network?
+                                       mappings)
+  "Return as a monadic value the derivation for IMAGE according to ACTION."
+  (mlet %store-monad ((target (current-target-system))
+                      (os -> (image-operating-system image))
+                      (image-size -> (image-size image)))
     (case action
       ((build init reconfigure)
        (operating-system-derivation os))
@@ -695,8 +697,6 @@ checking this by themselves in their 'check' procedure."
         os
         #:mappings mappings
         #:shared-network? container-shared-network?))
-      ((vm-image)
-       (system-qemu-image os #:disk-image-size image-size))
       ((vm)
        (system-qemu-image/shared-store-script os
                                               #:full-boot? full-boot?
@@ -705,21 +705,12 @@ checking this by themselves in their 'check' procedure."
                                                   image-size
                                                   (* 70 (expt 2 20)))
                                               #:mappings mappings))
-      ((image disk-image)
-       (let* ((base-image (os->image os #:type image-type))
-              (base-target (image-target base-image)))
-         (when (eq? action 'disk-image)
-           (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
-         (lower-object
-          (system-image
-           (image
-            (inherit (if label
-                         (image-with-label base-image label)
-                         base-image))
-            (target (or base-target target))
-            (size image-size)
-            (operating-system os)
-            (volatile-root? volatile-root?))))))
+      ((image disk-image vm-image)
+       (when (eq? action 'disk-image)
+         (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
+       (when (eq? action 'vm-image)
+         (warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
+       (lower-object (system-image image)))
       ((docker-image)
        (system-docker-image os
                             #:shared-network? container-shared-network?)))))
@@ -765,7 +756,7 @@ and TARGET arguments."
      (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
      (return (primitive-eval (lowered-gexp-sexp lowered))))))
 
-(define* (perform-action action os
+(define* (perform-action action image
                          #:key
                          (validate-reconfigure ensure-forward-reconfigure)
                          save-provenance?
@@ -773,17 +764,13 @@ and TARGET arguments."
                          install-bootloader?
                          dry-run? derivations-only?
                          use-substitutes? bootloader-target target
-                         image-size image-type
-                         volatile-root?
-                         full-boot? label container-shared-network?
+                         full-boot?
+                         container-shared-network?
                          (mappings '())
                          (gc-root #f))
-  "Perform ACTION for OS.  INSTALL-BOOTLOADER? specifies whether to install
+  "Perform ACTION for IMAGE.  INSTALL-BOOTLOADER? specifies whether to install
 bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
-target root directory; IMAGE-SIZE is the size of the image to be built, for
-the 'vm-image' and 'image' actions.  IMAGE-TYPE is the type of image to
-be built.  When VOLATILE-ROOT? is #t, the root file system is mounted
-volatile.
+target root directory.
 
 FULL-BOOT? is used for the 'vm' action; it determines whether to
 boot directly to the kernel or to the bootloader.  CONTAINER-SHARED-NETWORK?
@@ -805,6 +792,9 @@ static checks."
         '()
         (map boot-parameters->menu-entry (profile-boot-parameters))))
 
+  (define os
+    (image-operating-system image))
+
   (define bootloader
     (operating-system-bootloader os))
 
@@ -827,11 +817,7 @@ static checks."
       (check-initrd-modules os)))
 
   (mlet* %store-monad
-      ((sys       (system-derivation-for-action os action
-                                                #:label label
-                                                #:image-type image-type
-                                                #:image-size image-size
-                                                #:volatile-root? volatile-root?
+      ((sys       (system-derivation-for-action image action
                                                 #:full-boot? full-boot?
                                                 #:container-shared-network? container-shared-network?
                                                 #:mappings mappings))
@@ -969,8 +955,6 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "\
    vm               build a virtual machine image that shares the host's store\n"))
   (display (G_ "\
-   vm-image         build a freestanding virtual machine image\n"))
-  (display (G_ "\
    image            build a Guix System image\n"))
   (display (G_ "\
    docker-image     build a Docker image\n"))
@@ -999,7 +983,7 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
   -t, --image-type=TYPE  for 'image', produce an image of TYPE"))
   (display (G_ "
-      --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
+      --image-size=SIZE  for 'image', produce an image of SIZE"))
   (display (G_ "
       --no-bootloader    for 'init', do not install a bootloader"))
   (display (G_ "
@@ -1017,8 +1001,8 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
   -N, --network          for 'container', allow containers to access the network"))
   (display (G_ "
-  -r, --root=FILE        for 'vm', 'vm-image', 'image', 'container',
-                         and 'build', make FILE a symlink to the result, and
+  -r, --root=FILE        for 'vm', 'image', 'container' and 'build',
+                         make FILE a symlink to the result, and
                          register it as a garbage collector root"))
   (display (G_ "
       --full-boot        for 'vm', make a full boot sequence"))
@@ -1169,9 +1153,9 @@ Some ACTIONS support additional ARGS.\n"))
 ACTION must be one of the sub-commands that takes an operating system
 declaration as an argument (a file name.)  OPTS is the raw alist of options
 resulting from command-line parsing."
-  (define (ensure-operating-system file-or-exp obj)
-    (unless (operating-system? obj)
-      (leave (G_ "'~a' does not return an operating system~%")
+  (define (ensure-operating-system-or-image file-or-exp obj)
+    (unless (or (operating-system? obj) (image? obj))
+      (leave (G_ "'~a' does not return an operating system or an image~%")
              file-or-exp))
     obj)
 
@@ -1185,27 +1169,47 @@ resulting from command-line parsing."
          (expr        (assoc-ref opts 'expression))
          (system      (assoc-ref opts 'system))
          (target      (assoc-ref opts 'target))
-         (transform   (if save-provenance?
-                          (cut operating-system-with-provenance <> file)
-                          identity))
-         (os          (transform
-                       (ensure-operating-system
-                        (or file expr)
-                        (cond
-                         ((and expr file)
-                          (leave
-                           (G_ "both file and expression cannot be specified~%")))
-                         (expr
-                          (read/eval expr))
-                         (file
-                          (load* file %user-module
-                                 #:on-error (assoc-ref opts 'on-error)))
-                         (else
-                          (leave (G_ "no configuration specified~%")))))))
-
+         (transform   (lambda (obj)
+                        (if (and save-provenance? (operating-system? obj))
+                            (operating-system-with-provenance obj file)
+                            obj)))
+         (obj          (transform
+                        (ensure-operating-system-or-image
+                         (or file expr)
+                         (cond
+                          ((and expr file)
+                           (leave
+                            (G_ "both file and expression cannot be specified~%")))
+                          (expr
+                           (read/eval expr))
+                          (file
+                           (load* file %user-module
+                                  #:on-error (assoc-ref opts 'on-error)))
+                          (else
+                           (leave (G_ "no configuration specified~%")))))))
          (dry?        (assoc-ref opts 'dry-run?))
          (bootloader? (assoc-ref opts 'install-bootloader?))
          (label       (assoc-ref opts 'label))
+         (image-type  (lookup-image-type-by-name
+                       (assoc-ref opts 'image-type)))
+         (image       (let* ((image-type (if (eq? action 'vm-image)
+                                            qcow2-image-type
+                                            image-type))
+                            (image-size (assoc-ref opts 'image-size))
+                            (volatile?  (assoc-ref opts 'volatile-root?))
+                            (base-image (if (operating-system? obj)
+                                            (os->image obj
+                                                       #:type image-type)
+                                            obj))
+                            (base-target (image-target base-image)))
+                        (image
+                         (inherit (if label
+                                      (image-with-label base-image label)
+                                      base-image))
+                         (target (or base-target target))
+                         (size image-size)
+                         (volatile-root? volatile?))))
+         (os          (image-operating-system image))
          (target-file (match args
                         ((first second) second)
                         (_ #f)))
@@ -1241,7 +1245,7 @@ resulting from command-line parsing."
                  (warn-about-old-distro #:suggested-command
                                         "guix system reconfigure"))
 
-               (perform-action action os
+               (perform-action action image
                                #:dry-run? dry?
                                #:derivations-only? (assoc-ref opts
                                                               'derivations-only?)
@@ -1250,11 +1254,6 @@ resulting from command-line parsing."
                                (assoc-ref opts 'skip-safety-checks?)
                                #:validate-reconfigure
                                (assoc-ref opts 'validate-reconfigure)
-                               #:image-type (lookup-image-type-by-name
-                                             (assoc-ref opts 'image-type))
-                               #:image-size (assoc-ref opts 'image-size)
-                               #:volatile-root?
-                               (assoc-ref opts 'volatile-root?)
                                #:full-boot? (assoc-ref opts 'full-boot?)
                                #:container-shared-network?
                                (assoc-ref opts 'container-shared-network?)
@@ -1264,7 +1263,6 @@ resulting from command-line parsing."
                                                         (_ #f))
                                                       opts)
                                #:install-bootloader? bootloader?
-                               #:label label
                                #:target target-file
                                #:bootloader-target bootloader-target
                                #:gc-root (assoc-ref opts 'gc-root)))))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 97e4a73802..9e94bff5a3 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -32,7 +32,7 @@
   #:use-module (guix gexp)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
   #:use-module ((guix build utils) #:select (every*))
-  #:use-module (guix scripts substitute)
+  #:use-module (guix substitutes)
   #:use-module (guix narinfo)
   #:use-module (guix http-client)
   #:use-module (guix ci)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 9d0739f6c5..9b888a7d25 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -199,6 +199,37 @@ substitute invalid byte sequences with question marks.  This is a
 (define write-store-path-list write-string-list)
 (define read-store-path-list read-string-list)
 
+(define-syntax write-literal-strings
+  (lambda (s)
+    "Write the given literal strings to PORT in an optimized fashion, without
+any run-time allocations or computations."
+    (define (padding len)
+      (let ((m (modulo len 8)))
+        (if (zero? m)
+            0
+            (- 8 m))))
+
+    (syntax-case s ()
+      ((_ port strings ...)
+       (let* ((bytes (map string->utf8 (syntax->datum #'(strings ...))))
+              (len   (fold (lambda (bv size)
+                             (+ size 8 (bytevector-length bv)
+                                     (padding (bytevector-length bv))))
+                           0
+                           bytes))
+              (bv    (make-bytevector len))
+              (zeros (make-bytevector 8 0)))
+         (fold (lambda (str offset)
+                 (let ((len (bytevector-length str)))
+                   (bytevector-u32-set! bv offset len (endianness little))
+                   (bytevector-copy! str 0 bv (+ 8 offset) len)
+                   (bytevector-copy! zeros 0 bv (+ 8 offset len)
+                                     (padding len))
+                   (+ offset 8 len (padding len))))
+               0
+               bytes)
+         #`(put-bytevector port #,bv))))))
+
 
 (define-condition-type &nar-read-error &nar-error
   nar-read-error?
@@ -332,14 +363,12 @@ which case you can use 'identity'."
     (define-values (type size)
       (file-type+size f))
 
-    (write-string "(" p)
+    (write-literal-strings p "(")
     (case type
       ((regular executable)
-       (write-string "type" p)
-       (write-string "regular" p)
+       (write-literal-strings p "type" "regular")
        (when (eq? 'executable type)
-         (write-string "executable" p)
-         (write-string "" p))
+         (write-literal-strings p "executable" ""))
        (let ((input (file-port f)))
          (dynamic-wind
            (const #t)
@@ -348,28 +377,23 @@ which case you can use 'identity'."
            (lambda ()
              (close-port input)))))
       ((directory)
-       (write-string "type" p)
-       (write-string "directory" p)
+       (write-literal-strings p "type" "directory")
        (let ((entries (postprocess-entries (directory-entries f))))
          (for-each (lambda (e)
                      (let* ((f (string-append f "/" e)))
-                       (write-string "entry" p)
-                       (write-string "(" p)
-                       (write-string "name" p)
+                       (write-literal-strings p "entry" "(" "name")
                        (write-string e p)
-                       (write-string "node" p)
+                       (write-literal-strings p "node")
                        (dump f)
-                       (write-string ")" p)))
+                       (write-literal-strings p ")")))
                    entries)))
       ((symlink)
-       (write-string "type" p)
-       (write-string "symlink" p)
-       (write-string "target" p)
+       (write-literal-strings p "type" "symlink" "target")
        (write-string (symlink-target f) p))
       (else
        (raise (condition (&message (message "unsupported file type"))
                          (&nar-error (file f) (port port))))))
-    (write-string ")" p)))
+    (write-literal-strings p ")")))
 
 (define port-conversion-strategy
   (fluid->parameter %default-port-conversion-strategy))
diff --git a/guix/store.scm b/guix/store.scm
index 81bb9eb847..37ae6cfedd 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1835,18 +1835,21 @@ and RESULT is typically its derivation."
   (if (profiled? "object-cache")
       (let ((fresh    0)
             (lookups  0)
-            (hits     0))
+            (hits     0)
+            (size     0))
         (register-profiling-hook!
          "object-cache"
          (lambda ()
            (format (current-error-port) "Store object cache:
   fresh caches: ~5@a
   lookups:      ~5@a
-  hits:         ~5@a (~,1f%)~%"
+  hits:         ~5@a (~,1f%)
+  cache size:   ~5@a entries~%"
                    fresh lookups hits
                    (if (zero? lookups)
                        100.
-                       (* 100. (/ hits lookups))))))
+                       (* 100. (/ hits lookups)))
+                   size)))
 
         (lambda (hit? cache)
           (set! fresh
@@ -1854,12 +1857,13 @@ and RESULT is typically its derivation."
                 (+ 1 fresh)
                 fresh))
           (set! lookups (+ 1 lookups))
-          (set! hits (if hit? (+ hits 1) hits))))
+          (set! hits (if hit? (+ hits 1) hits))
+          (set! size (+ (if hit? 0 1)
+                        (vlist-length cache)))))
       (lambda (x y)
         #t)))
 
-(define* (lookup-cached-object object #:optional (keys '())
-                               #:key (vhash-fold* vhash-foldq*))
+(define-inlinable (lookup-cached-object object keys vhash-fold*)
   "Return the cached object in the store connection corresponding to OBJECT
 and KEYS; use VHASH-FOLD* to look for OBJECT in the cache.  KEYS is a list of
 additional keys to match against, and which are compared with 'equal?'.
@@ -1890,7 +1894,7 @@ Return #f on failure and the cached result otherwise."
 OBJECT/KEYS, or return its cached value.  Use VHASH-CONS to insert OBJECT into
 the cache, and VHASH-FOLD* to look it up."
   (mlet %store-monad ((cached (lookup-cached-object object keys
-                                                    #:vhash-fold* vhash-fold*)))
+                                                    vhash-fold*)))
     (if cached
         (return cached)
         (>>= (mthunk)
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
new file mode 100644
index 0000000000..dc94ccc8e4
--- /dev/null
+++ b/guix/substitutes.scm
@@ -0,0 +1,366 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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 substitutes)
+  #:use-module (guix narinfo)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix combinators)
+  #:use-module (guix config)
+  #:use-module (guix records)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
+  #:use-module (gcrypt hash)
+  #:use-module (guix base32)
+  #:use-module (guix base64)
+  #:use-module (guix cache)
+  #:use-module (gcrypt pk-crypto)
+  #:use-module (guix pki)
+  #:use-module ((guix build utils) #:select (mkdir-p dump-port))
+  #:use-module ((guix build download)
+                #:select ((open-connection-for-uri
+                           . guix:open-connection-for-uri)))
+  #:use-module (guix progress)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 vlist)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (guix http-client)
+  #:export (%narinfo-cache-directory
+
+            call-with-connection-error-handling
+
+            lookup-narinfos
+            lookup-narinfos/diverse))
+
+(define %narinfo-ttl
+  ;; Number of seconds during which cached narinfo lookups are considered
+  ;; valid for substitute servers that do not advertise a TTL via the
+  ;; 'Cache-Control' response header.
+  (* 36 3600))
+
+(define %narinfo-negative-ttl
+  ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
+  (* 1 3600))
+
+(define %narinfo-transient-error-ttl
+  ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
+  (* 10 60))
+
+(define %narinfo-cache-directory
+  ;; A local cache of narinfos, to avoid going to the network.  Most of the
+  ;; time, 'guix substitute' is called by guix-daemon as root and stores its
+  ;; cached data in /var/guix/….  However, when invoked from 'guix challenge'
+  ;; as a user, it stores its cache in ~/.cache.
+  (if (zero? (getuid))
+      (or (and=> (getenv "XDG_CACHE_HOME")
+                 (cut string-append <> "/guix/substitute"))
+          (string-append %state-directory "/substitute/cache"))
+      (string-append (cache-directory #:ensure? #f) "/substitute")))
+
+(define (narinfo-cache-file cache-url path)
+  "Return the name of the local file that contains an entry for PATH.  The
+entry is stored in a sub-directory specific to CACHE-URL."
+  ;; The daemon does not sanitize its input, so PATH could be something like
+  ;; "/gnu/store/foo".  Gracefully handle that.
+  (match (store-path-hash-part path)
+    (#f
+     (leave (G_ "'~a' does not name a store item~%") path))
+    ((? string? hash-part)
+     (string-append %narinfo-cache-directory "/"
+                    (bytevector->base32-string (sha256 (string->utf8 cache-url)))
+                    "/" hash-part))))
+
+(define (cache-narinfo! cache-url path narinfo ttl)
+  "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
+given TTL (a number of seconds or #f).  NARINFO may be #f, in which case it
+indicates that PATH is unavailable at CACHE-URL."
+  (define now
+    (current-time time-monotonic))
+
+  (define (cache-entry cache-uri narinfo)
+    `(narinfo (version 2)
+              (cache-uri ,cache-uri)
+              (date ,(time-second now))
+              (ttl ,(or ttl
+                        (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
+              (value ,(and=> narinfo narinfo->string))))
+
+  (let ((file (narinfo-cache-file cache-url path)))
+    (mkdir-p (dirname file))
+    (with-atomic-file-output file
+      (lambda (out)
+        (write (cache-entry cache-url narinfo) out))))
+
+  narinfo)
+
+(define %unreachable-hosts
+  ;; Set of names of unreachable hosts.
+  (make-hash-table))
+
+(define* (call-with-connection-error-handling uri proc)
+  "Call PROC, and catch if a connection fails, print a warning and return #f."
+  (define host
+    (uri-host uri))
+
+  (catch #t
+    proc
+    (match-lambda*
+      (('getaddrinfo-error error)
+       (unless (hash-ref %unreachable-hosts host)
+         (hash-set! %unreachable-hosts host #t)   ;warn only once
+         (warning (G_ "~a: host not found: ~a~%")
+                  host (gai-strerror error)))
+       #f)
+      (('system-error . args)
+       (unless (hash-ref %unreachable-hosts host)
+         (hash-set! %unreachable-hosts host #t)
+         (warning (G_ "~a: connection failed: ~a~%") host
+                  (strerror
+                   (system-error-errno `(system-error ,@args)))))
+       #f)
+      (args
+       (apply throw args)))))
+
+(define (narinfo-request cache-url path)
+  "Return an HTTP request for the narinfo of PATH at CACHE-URL."
+  (let ((url (string-append cache-url "/" (store-path-hash-part path)
+                            ".narinfo"))
+        (headers '((User-Agent . "GNU Guile"))))
+    (build-request (string->uri url) #:method 'GET #:headers headers)))
+
+(define (narinfo-from-file file url)
+  "Attempt to read a narinfo from FILE, using URL as the cache URL.  Return #f
+if file doesn't exist, and the narinfo otherwise."
+  (catch 'system-error
+    (lambda ()
+      (call-with-input-file file
+        (cut read-narinfo <> url)))
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          #f
+          (apply throw args)))))
+
+(define* (fetch-narinfos url paths
+                         #:key (open-connection guix:open-connection-for-uri))
+  "Retrieve all the narinfos for PATHS from the cache at URL and return them."
+  (define update-progress!
+    (let ((done 0)
+          (total (length paths)))
+      (lambda ()
+        (display "\r\x1b[K" (current-error-port)) ;erase current line
+        (force-output (current-error-port))
+        (format (current-error-port)
+                (G_ "updating substitutes from '~a'... ~5,1f%")
+                url (* 100. (/ done total)))
+        (set! done (+ 1 done)))))
+
+  (define hash-part->path
+    (let ((mapping (fold (lambda (path result)
+                           (vhash-cons (store-path-hash-part path) path
+                                       result))
+                         vlist-null
+                         paths)))
+      (lambda (hash)
+        (match (vhash-assoc hash mapping)
+          (#f #f)
+          ((_ . path) path)))))
+
+  (define (read-to-eof port)
+    "Read from PORT until EOF is reached.  The data are discarded."
+    (dump-port port (%make-void-port "w")))
+
+  (define (handle-narinfo-response request response port result)
+    (let* ((code   (response-code response))
+           (len    (response-content-length response))
+           (cache  (response-cache-control response))
+           (ttl    (and cache (assoc-ref cache 'max-age))))
+      (update-progress!)
+
+      ;; Make sure to read no more than LEN bytes since subsequent bytes may
+      ;; belong to the next response.
+      (if (= code 200)                            ; hit
+          (let ((narinfo (read-narinfo port url #:size len)))
+            (if (string=? (dirname (narinfo-path narinfo))
+                          (%store-prefix))
+                (begin
+                  (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
+                  (cons narinfo result))
+                result))
+          (let* ((path      (uri-path (request-uri request)))
+                 (hash-part (basename
+                             (string-drop-right path 8)))) ;drop ".narinfo"
+            (if len
+                (get-bytevector-n port len)
+                (read-to-eof port))
+            (cache-narinfo! url (hash-part->path hash-part) #f
+                            (if (or (= 404 code) (= 202 code))
+                                ttl
+                                %narinfo-transient-error-ttl))
+            result))))
+
+  (define (do-fetch uri)
+    (case (and=> uri uri-scheme)
+      ((http https)
+       ;; Note: Do not check HTTPS server certificates to avoid depending
+       ;; on the X.509 PKI.  We can do it because we authenticate
+       ;; narinfos, which provides a much stronger guarantee.
+       (let* ((requests (map (cut narinfo-request url <>) paths))
+              (result   (begin
+                          (update-progress!)
+                          (call-with-connection-error-handling
+                           uri
+                           (lambda ()
+                             (http-multiple-get uri
+                                                handle-narinfo-response '()
+                                                requests
+                                                #:open-connection open-connection
+                                                #:verify-certificate? #f))))))
+         (newline (current-error-port))
+         result))
+      ((file #f)
+       (let* ((base  (string-append (uri-path uri) "/"))
+              (files (map (compose (cut string-append base <> ".narinfo")
+                                   store-path-hash-part)
+                          paths)))
+         (filter-map (cut narinfo-from-file <> url) files)))
+      (else
+       (leave (G_ "~s: unsupported server URI scheme~%")
+              (if uri (uri-scheme uri) url)))))
+
+  (do-fetch (string->uri url)))
+
+(define (cached-narinfo cache-url path)
+  "Check locally if we have valid info about PATH coming from CACHE-URL.
+Return two values: a Boolean indicating whether we have valid cached info, and
+that info, which may be either #f (when PATH is unavailable) or the narinfo
+for PATH."
+  (define now
+    (current-time time-monotonic))
+
+  (define cache-file
+    (narinfo-cache-file cache-url path))
+
+  (catch 'system-error
+    (lambda ()
+      (call-with-input-file cache-file
+        (lambda (p)
+          (match (read p)
+            (('narinfo ('version 2)
+                       ('cache-uri cache-uri)
+                       ('date date) ('ttl ttl) ('value #f))
+             ;; A cached negative lookup.
+             (if (obsolete? date now ttl)
+                 (values #f #f)
+                 (values #t #f)))
+            (('narinfo ('version 2)
+                       ('cache-uri cache-uri)
+                       ('date date) ('ttl ttl) ('value value))
+             ;; A cached positive lookup
+             (if (obsolete? date now ttl)
+                 (values #f #f)
+                 (values #t (string->narinfo value cache-uri))))
+            (('narinfo ('version v) _ ...)
+             (values #f #f))))))
+    (lambda _
+      (values #f #f))))
+
+(define* (lookup-narinfos cache paths
+                          #:key (open-connection guix:open-connection-for-uri))
+  "Return the narinfos for PATHS, invoking the server at CACHE when no
+information is available locally."
+  (let-values (((cached missing)
+                (fold2 (lambda (path cached missing)
+                         (let-values (((valid? value)
+                                       (cached-narinfo cache path)))
+                           (if valid?
+                               (if value
+                                   (values (cons value cached) missing)
+                                   (values cached missing))
+                               (values cached (cons path missing)))))
+                       '()
+                       '()
+                       paths)))
+    (if (null? missing)
+        cached
+        (let ((missing (fetch-narinfos cache missing
+                                       #:open-connection open-connection)))
+          (append cached (or missing '()))))))
+
+(define* (lookup-narinfos/diverse caches paths authorized?
+                                  #:key (open-connection
+                                         guix:open-connection-for-uri))
+  "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
+That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
+cache, and so on.
+
+Return a list of narinfos for PATHS or a subset thereof.  The returned
+narinfos are either AUTHORIZED?, or they claim a hash that matches an
+AUTHORIZED? narinfo."
+  (define (select-hit result)
+    (lambda (path)
+      (match (vhash-fold* cons '() path result)
+        ((one)
+         one)
+        ((several ..1)
+         (let ((authorized (find authorized? (reverse several))))
+           (and authorized
+                (find (cut equivalent-narinfo? <> authorized)
+                      several)))))))
+
+  (let loop ((caches caches)
+             (paths  paths)
+             (result vlist-null)                  ;path->narinfo vhash
+             (hits   '()))                        ;paths
+    (match paths
+      (()                                         ;we're done
+       ;; Now iterate on all the HITS, and return exactly one match for each
+       ;; hit: the first narinfo that is authorized, or that has the same hash
+       ;; as an authorized narinfo, in the order of CACHES.
+       (filter-map (select-hit result) hits))
+      (_
+       (match caches
+         ((cache rest ...)
+          (let* ((narinfos (lookup-narinfos cache paths
+                                            #:open-connection open-connection))
+                 (definite (map narinfo-path (filter authorized? narinfos)))
+                 (missing  (lset-difference string=? paths definite))) ;XXX: perf
+            (loop rest missing
+                  (fold vhash-cons result
+                        (map narinfo-path narinfos) narinfos)
+                  (append definite hits))))
+         (()                                      ;that's it
+          (filter-map (select-hit result) hits)))))))
+
+;;; substitutes.scm ends here
diff --git a/guix/tests.scm b/guix/tests.scm
index da75835099..4c6c7d95db 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -143,7 +143,7 @@ no external store to talk to."
       (lambda ()
         ;; Since we're using a different store we must clear the
         ;; package-derivation cache.
-        (hash-clear! (@@ (guix packages) %derivation-cache))
+        (hash-clear! (@@ (guix derivations) %derivation-cache))
 
         (proc store))
       (lambda ()
diff --git a/guix/ui.scm b/guix/ui.scm
index 9cea405456..7fbd4c63a2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -552,7 +552,9 @@ Report bugs to: ~a.") %guix-bug-report-address)
 ~a home page: <~a>") %guix-package-name %guix-home-page-url)
   (format #t (G_ "
 General help using Guix and GNU software: <~a>")
-           "https://guix.gnu.org/help/")
+          ;; TRANSLATORS: Change the "/en" bit of this URL appropriately if
+          ;; the web site is translated in your language.
+          (G_ "https://guix.gnu.org/en/help/"))
   (newline))
 
 (define (augmented-system-error-handler file)
@@ -1968,7 +1970,7 @@ way."
     display-generation-change))
 
 (define (switch-to-generation* profile number)
-  "Like 'switch-generation', but display what is happening."
+  "Like 'switch-to-generation', but display what is happening."
   (let ((previous (switch-to-generation profile number)))
     (display-generation-change previous number)))