Merge branch 'master' into core-updates

9 files changed, 326 insertions, 279 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 0f2d5f402a..c647d00f6b 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -457,135 +457,6 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
                 'set-port-encoding!
                 (lambda (p e) #f))
 
-;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit
-;; 16050431f29d56f80c4a8253506fc851b8441840.  Guile's date validation
-;; procedure rejects dates in which the hour is not padded with a zero but
-;; with whitespace.
-(begin
-  (define-syntax string-match?
-    (lambda (x)
-      (syntax-case x ()
-        ((_ str pat) (string? (syntax->datum #'pat))
-         (let ((p (syntax->datum #'pat)))
-           #`(let ((s str))
-               (and
-                (= (string-length s) #,(string-length p))
-                #,@(let lp ((i 0) (tests '()))
-                     (if (< i (string-length p))
-                         (let ((c (string-ref p i)))
-                           (lp (1+ i)
-                               (case c
-                                 ((#\.)  ; Whatever.
-                                  tests)
-                                 ((#\d)  ; Digit.
-                                  (cons #`(char-numeric? (string-ref s #,i))
-                                        tests))
-                                 ((#\a)  ; Alphabetic.
-                                  (cons #`(char-alphabetic? (string-ref s #,i))
-                                        tests))
-                                 (else   ; Literal.
-                                  (cons #`(eqv? (string-ref s #,i) #,c)
-                                        tests)))))
-                         tests)))))))))
-
-  (define (parse-rfc-822-date str space zone-offset)
-    (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer))
-          (parse-month (@@ (web http) parse-month))
-          (bad-header (@@ (web http) bad-header)))
-      ;; We could verify the day of the week but we don't.
-      (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
-             (let ((date (parse-non-negative-integer str 5 7))
-                   (month (parse-month str 8 11))
-                   (year (parse-non-negative-integer str 12 16))
-                   (hour (parse-non-negative-integer str 17 19))
-                   (minute (parse-non-negative-integer str 20 22))
-                   (second (parse-non-negative-integer str 23 25)))
-               (make-date 0 second minute hour date month year zone-offset)))
-            ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
-             (let ((date (parse-non-negative-integer str 5 6))
-                   (month (parse-month str 7 10))
-                   (year (parse-non-negative-integer str 11 15))
-                   (hour (parse-non-negative-integer str 16 18))
-                   (minute (parse-non-negative-integer str 19 21))
-                   (second (parse-non-negative-integer str 22 24)))
-               (make-date 0 second minute hour date month year zone-offset)))
-
-            ;; The next two clauses match dates that have a space instead of
-            ;; a leading zero for hours, like " 8:49:37".
-            ((string-match? (substring str 0 space) "aaa, dd aaa dddd  d:dd:dd")
-             (let ((date (parse-non-negative-integer str 5 7))
-                   (month (parse-month str 8 11))
-                   (year (parse-non-negative-integer str 12 16))
-                   (hour (parse-non-negative-integer str 18 19))
-                   (minute (parse-non-negative-integer str 20 22))
-                   (second (parse-non-negative-integer str 23 25)))
-               (make-date 0 second minute hour date month year zone-offset)))
-            ((string-match? (substring str 0 space) "aaa, d aaa dddd  d:dd:dd")
-             (let ((date (parse-non-negative-integer str 5 6))
-                   (month (parse-month str 7 10))
-                   (year (parse-non-negative-integer str 11 15))
-                   (hour (parse-non-negative-integer str 17 18))
-                   (minute (parse-non-negative-integer str 19 21))
-                   (second (parse-non-negative-integer str 22 24)))
-               (make-date 0 second minute hour date month year zone-offset)))
-
-            (else
-             (bad-header 'date str)        ; prevent tail call
-             #f))))
-  (module-set! (resolve-module '(web http))
-               'parse-rfc-822-date parse-rfc-822-date))
-
-;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in
-;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and
-;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143.  See bug report at
-;; <https://lists.gnu.org/archive/html/guix-devel/2017-11/msg00070.html>.
-(cond-expand
-  (guile-2.2
-   (when (<= (string->number (micro-version)) 2)
-     (let ()
-       (define put-symbol (@@ (web http) put-symbol))
-       (define put-non-negative-integer
-         (@@ (web http) put-non-negative-integer))
-       (define write-http-version
-         (@@ (web http) write-http-version))
-
-       (define (write-request-line method uri version port)
-         "Write the first line of an HTTP request to PORT."
-         (put-symbol port method)
-         (put-char port #\space)
-         (when (http-proxy-port? port)
-           (let ((scheme (uri-scheme uri))
-                 (host (uri-host uri))
-                 (host-port (uri-port uri)))
-             (when (and scheme host)
-               (put-symbol port scheme)
-               (put-string port "://")
-               (cond
-                ((string-index host #\:)          ;<---- The fix is here!
-                 (put-char port #\[)              ;<---- And here!
-                 (put-string port host)
-                 (put-char port #\]))
-                (else
-                 (put-string port host)))
-               (unless ((@@ (web uri) default-port?) scheme host-port)
-                 (put-char port #\:)
-                 (put-non-negative-integer port host-port)))))
-         (let ((path (uri-path uri))
-               (query (uri-query uri)))
-           (if (string-null? path)
-               (put-string port "/")
-               (put-string port path))
-           (when query
-             (put-string port "?")
-             (put-string port query)))
-         (put-char port #\space)
-         (write-http-version version port)
-         (put-string port "\r\n"))
-
-       (module-set! (resolve-module '(web http)) 'write-request-line
-                    write-request-line))))
-  (else #t))
-
 (define (resolve-uri-reference ref base)
   "Resolve the URI reference REF, interpreted relative to the BASE URI, into a
 target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8a59599c28..5912511530 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -82,6 +82,9 @@
             raw-derivation-file
             raw-derivation-file?
 
+            with-parameters
+            parameterized?
+
             load-path-expression
             gexp-modules
 
@@ -523,6 +526,62 @@ SUFFIX."
                           (base   (expand base lowered output)))
                      (string-append base (string-concatenate suffix)))))))
 
+;; Representation of SRFI-39 parameter settings in the dynamic scope of an
+;; object lowering.
+(define-record-type <parameterized>
+  (parameterized bindings thunk)
+  parameterized?
+  (bindings parameterized-bindings)             ;list of parameter/value pairs
+  (thunk    parameterized-thunk))               ;thunk
+
+(define-syntax-rule (with-parameters ((param value) ...) body ...)
+  "Bind each PARAM to the corresponding VALUE for the extent during which BODY
+is lowered.  Consider this example:
+
+  (with-parameters ((%current-system \"x86_64-linux\"))
+    coreutils)
+
+It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to
+x86_64-linux when COREUTILS is lowered."
+  (parameterized (list (list param (lambda () value)) ...)
+                 (lambda ()
+                   body ...)))
+
+(define-gexp-compiler compile-parameterized <parameterized>
+  compiler =>
+  (lambda (parameterized system target)
+    (match (parameterized-bindings parameterized)
+      (((parameters values) ...)
+       (let ((fluids (map parameter-fluid parameters))
+             (thunk  (parameterized-thunk parameterized)))
+         ;; Install the PARAMETERS for the dynamic extent of THUNK.
+         (with-fluids* fluids
+           (map (lambda (thunk) (thunk)) values)
+           (lambda ()
+             ;; Special-case '%current-system' and '%current-target-system' to
+             ;; make sure we get the desired effect.
+             (let ((system (if (memq %current-system parameters)
+                               (%current-system)
+                               system))
+                   (target (if (memq %current-target-system parameters)
+                               (%current-target-system)
+                               target)))
+               (lower-object (thunk) system #:target target))))))))
+
+  expander => (lambda (parameterized lowered output)
+                (match (parameterized-bindings parameterized)
+                  (((parameters values) ...)
+                   (let ((fluids (map parameter-fluid parameters))
+                         (thunk  (parameterized-thunk parameterized)))
+                     ;; Install the PARAMETERS for the dynamic extent of THUNK.
+                     (with-fluids* fluids
+                       (map (lambda (thunk) (thunk)) values)
+                       (lambda ()
+                         ;; Delegate to the expander of the wrapped object.
+                         (let* ((base   (thunk))
+                                (expand (lookup-expander base)))
+                           (expand base lowered output)))))))))
+
 
 ;;;
 ;;; Inputs & outputs.
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index 7a97c7f8e8..6bcd2ce9eb 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -181,9 +181,9 @@ return \"Test-Simple\""
 or #f on failure.  MODULE should be the distribution name, such as
 \"Test-Script\" for the \"Test::Script\" module."
   ;; This API always returns the latest release of the module.
-  (json->cpan-release
-   (json-fetch (string-append (%metacpan-base-url) "/release/"
-                              name))))
+  (and=> (json-fetch (string-append (%metacpan-base-url) "/release/"
+                                    name))
+         json->cpan-release))
 
 (define (cpan-home name)
   (string-append "https://metacpan.org/release/" name))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 10450155a0..f93fa8831f 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -43,6 +43,7 @@
   #:use-module (guix import utils)
   #:use-module ((guix download) #:prefix download:)
   #:use-module (guix import json)
+  #:use-module (guix json)
   #:use-module (guix packages)
   #:use-module (guix upstream)
   #:use-module ((guix licenses) #:prefix license:)
@@ -55,10 +56,67 @@
             pypi->guix-package
             %pypi-updater))
 
+;; The PyPI API (notice the rhyme) is "documented" at:
+;; <https://warehouse.readthedocs.io/api-reference/json/>.
+
+(define non-empty-string-or-false
+  (match-lambda
+    ("" #f)
+    ((? string? str) str)
+    ((or #nil #f) #f)))
+
+;; PyPI project.
+(define-json-mapping <pypi-project> make-pypi-project pypi-project?
+  json->pypi-project
+  (info          pypi-project-info "info" json->project-info) ;<project-info>
+  (last-serial   pypi-project-last-serial "last_serial")      ;integer
+  (releases      pypi-project-releases "releases" ;string/<distribution>* pairs
+                 (match-lambda
+                   (((versions . dictionaries) ...)
+                    (map (lambda (version vector)
+                           (cons version
+                                 (map json->distribution
+                                      (vector->list vector))))
+                         versions dictionaries))))
+  (distributions pypi-project-distributions "urls" ;<distribution>*
+                 (lambda (vector)
+                   (map json->distribution (vector->list vector)))))
+
+;; Project metadata.
+(define-json-mapping <project-info> make-project-info project-info?
+  json->project-info
+  (name         project-info-name)                ;string
+  (author       project-info-author)              ;string
+  (maintainer   project-info-maintainer)          ;string
+  (classifiers  project-info-classifiers          ;list of strings
+                "classifiers" vector->list)
+  (description  project-info-description)         ;string
+  (summary      project-info-summary)             ;string
+  (keywords     project-info-keywords)            ;string
+  (license      project-info-license)             ;string
+  (download-url project-info-download-url         ;string | #f
+                "download_url" non-empty-string-or-false)
+  (home-page    project-info-home-page            ;string
+                "home_page")
+  (url          project-info-url "project_url")   ;string
+  (release-url  project-info-release-url "release_url") ;string
+  (version      project-info-version))            ;string
+
+;; Distribution: a URL along with cryptographic hashes and metadata.
+(define-json-mapping <distribution> make-distribution distribution?
+  json->distribution
+  (url          distribution-url)                  ;string
+  (digests      distribution-digests)              ;list of string pairs
+  (file-name    distribution-file-name "filename") ;string
+  (has-signature? distribution-has-signature? "hash_sig") ;Boolean
+  (package-type distribution-package-type "packagetype") ;"bdist_wheel" | ...
+  (python-version distribution-package-python-version
+                  "python_version"))
+
 (define (pypi-fetch name)
-  "Return an alist representation of the PyPI metadata for the package NAME,
-or #f on failure."
-  (json-fetch (string-append "https://pypi.org/pypi/" name "/json")))
+  "Return a <pypi-project> record for package NAME, or #f on failure."
+  (and=> (json-fetch (string-append "https://pypi.org/pypi/" name "/json"))
+         json->pypi-project))
 
 ;; For packages found on PyPI that lack a source distribution.
 (define-condition-type &missing-source-error &error
@@ -67,22 +125,24 @@ or #f on failure."
 
 (define (latest-source-release pypi-package)
   "Return the latest source release for PYPI-PACKAGE."
-  (let ((releases (assoc-ref* pypi-package "releases"
-                              (assoc-ref* pypi-package "info" "version"))))
+  (let ((releases (assoc-ref (pypi-project-releases pypi-package)
+                             (project-info-version
+                              (pypi-project-info pypi-package)))))
     (or (find (lambda (release)
-                (string=? "sdist" (assoc-ref release "packagetype")))
-              (vector->list releases))
+                (string=? "sdist" (distribution-package-type release)))
+              releases)
         (raise (condition (&missing-source-error
                            (package pypi-package)))))))
 
 (define (latest-wheel-release pypi-package)
   "Return the url of the wheel for the latest release of pypi-package,
 or #f if there isn't any."
-  (let ((releases (assoc-ref* pypi-package "releases"
-                              (assoc-ref* pypi-package "info" "version"))))
+  (let ((releases (assoc-ref (pypi-project-releases pypi-package)
+                             (project-info-version
+                              (pypi-project-info pypi-package)))))
     (or (find (lambda (release)
-                (string=? "bdist_wheel" (assoc-ref release "packagetype")))
-              (vector->list releases))
+                (string=? "bdist_wheel" (distribution-package-type release)))
+              releases)
         #f)))
 
 (define (python->package-name name)
@@ -411,23 +471,25 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
    (lambda* (package-name)
      "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the
 `package' s-expression corresponding to that package, or #f on failure."
-     (let ((package (pypi-fetch package-name)))
-       (and package
+     (let* ((project (pypi-fetch package-name))
+            (info    (and project (pypi-project-info project))))
+       (and project
             (guard (c ((missing-source-error? c)
                        (let ((package (missing-source-error-package c)))
                          (leave (G_ "no source release for pypi package ~a ~a~%")
-                                (assoc-ref* package "info" "name")
-                                (assoc-ref* package "info" "version")))))
-              (let ((name (assoc-ref* package "info" "name"))
-                    (version (assoc-ref* package "info" "version"))
-                    (release (assoc-ref (latest-source-release package) "url"))
-                    (wheel (assoc-ref (latest-wheel-release package) "url"))
-                    (synopsis (assoc-ref* package "info" "summary"))
-                    (description (assoc-ref* package "info" "summary"))
-                    (home-page (assoc-ref* package "info" "home_page"))
-                    (license (string->license (assoc-ref* package "info" "license"))))
-                (make-pypi-sexp name version release wheel home-page synopsis
-                                description license))))))))
+                                (project-info-name info)
+                                (project-info-version info)))))
+              (make-pypi-sexp (project-info-name info)
+                              (project-info-version info)
+                              (and=> (latest-source-release project)
+                                     distribution-url)
+                              (and=> (latest-wheel-release project)
+                                     distribution-url)
+                              (project-info-home-page info)
+                              (project-info-summary info)
+                              (project-info-summary info)
+                              (string->license
+                               (project-info-license info)))))))))
 
 (define (pypi-recursive-import package-name)
   (recursive-import package-name #f
@@ -472,9 +534,10 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
          (pypi-package (pypi-fetch pypi-name)))
     (and pypi-package
          (guard (c ((missing-source-error? c) #f))
-           (let* ((metadata pypi-package)
-                  (version (assoc-ref* metadata "info" "version"))
-                  (url (assoc-ref (latest-source-release metadata) "url")))
+           (let* ((info    (pypi-project-info pypi-package))
+                  (version (project-info-version info))
+                  (url     (distribution-url
+                            (latest-source-release pypi-package))))
              (upstream-source
               (package (package-name package))
               (version version)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index d17d400ddf..94c8cb040b 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
@@ -47,7 +47,6 @@
   #:export (factorize-uri
 
             flatten
-            assoc-ref*
 
             url-fetch
             guix-hash-url
@@ -110,13 +109,6 @@ of the string VERSION is replaced by the symbol 'version."
      (cons elem memo)))
    '() lst))
 
-(define (assoc-ref* alist key . rest)
-  "Return the value for KEY from ALIST.  For each additional key specified,
-recursively apply the procedure to the sub-list."
-  (if (null? rest)
-      (assoc-ref alist key)
-      (apply assoc-ref* (assoc-ref alist key) rest)))
-
 (define (url-fetch url file-name)
   "Save the contents of URL to FILE-NAME.  Return #f on failure."
   (parameterize ((current-output-port (current-error-port)))
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 0236fb61ad..6b685ece30 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -63,6 +63,9 @@
             inferior-eval
             inferior-eval-with-store
             inferior-object?
+            inferior-exception?
+            inferior-exception-arguments
+            inferior-exception-inferior
             read-repl-response
 
             inferior-packages
@@ -195,8 +198,15 @@ equivalent.  Return #f if the inferior could not be launched."
 
 (set-record-type-printer! <inferior-object> write-inferior-object)
 
-(define (read-repl-response port)
-  "Read a (guix repl) response from PORT and return it as a Scheme object."
+;; Reified exception thrown by an inferior.
+(define-condition-type &inferior-exception &error
+  inferior-exception?
+  (arguments  inferior-exception-arguments)       ;key + arguments
+  (inferior   inferior-exception-inferior))       ;<inferior> | #f
+
+(define* (read-repl-response port #:optional inferior)
+  "Read a (guix repl) response from PORT and return it as a Scheme object.
+Raise '&inferior-exception' when an exception is read from PORT."
   (define sexp->object
     (match-lambda
       (('value value)
@@ -208,10 +218,13 @@ equivalent.  Return #f if the inferior could not be launched."
     (('values objects ...)
      (apply values (map sexp->object objects)))
     (('exception key objects ...)
-     (apply throw key (map sexp->object objects)))))
+     (raise (condition (&inferior-exception
+                        (arguments (cons key (map sexp->object objects)))
+                        (inferior inferior)))))))
 
 (define (read-inferior-response inferior)
-  (read-repl-response (inferior-socket inferior)))
+  (read-repl-response (inferior-socket inferior)
+                      inferior))
 
 (define (send-inferior-request exp inferior)
   (write exp (inferior-socket inferior))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c8d8546e29..652b4c63c4 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -365,6 +365,21 @@ added to the pack."
           (define database #+database)
           (define entry-point #$entry-point)
 
+          (define (mksquashfs args)
+            (apply invoke "mksquashfs"
+                   `(,@args
+
+                     ;; Do not create a "recovery file" when appending to the
+                     ;; file system since it's useless in this case.
+                     "-no-recovery"
+
+                     ;; Set file times and the file system creation time to
+                     ;; one second after the Epoch.
+                     "-all-time" "1" "-mkfs-time" "1"
+
+                     ;; Reset all UIDs and GIDs.
+                     "-force-uid" "0" "-force-gid" "0")))
+
           (setenv "PATH" (string-append #$archiver "/bin"))
 
           ;; We need an empty file in order to have a valid file argument when
@@ -376,92 +391,90 @@ added to the pack."
           ;; Add all store items.  Unfortunately mksquashfs throws away all
           ;; ancestor directories and only keeps the basename.  We fix this
           ;; in the following invocations of mksquashfs.
-          (apply invoke "mksquashfs"
-                 `(,@(map store-info-item
-                          (call-with-input-file "profile"
-                            read-reference-graph))
-                   #$environment
-                   ,#$output
-
-                   ;; Do not perform duplicate checking because we
-                   ;; don't have any dupes.
-                   "-no-duplicates"
-                   "-comp"
-                   ,#+(compressor-name compressor)))
+          (mksquashfs `(,@(map store-info-item
+                               (call-with-input-file "profile"
+                                 read-reference-graph))
+                        #$environment
+                        ,#$output
+
+                        ;; Do not perform duplicate checking because we
+                        ;; don't have any dupes.
+                        "-no-duplicates"
+                        "-comp"
+                        ,#+(compressor-name compressor)))
 
           ;; Here we reparent the store items.  For each sub-directory of
           ;; the store prefix we need one invocation of "mksquashfs".
           (for-each (lambda (dir)
-                      (apply invoke "mksquashfs"
-                             `(".empty"
-                               ,#$output
-                               "-root-becomes" ,dir)))
+                      (mksquashfs `(".empty"
+                                    ,#$output
+                                    "-root-becomes" ,dir)))
                     (reverse (string-tokenize (%store-directory)
                                               (char-set-complement (char-set #\/)))))
 
           ;; Add symlinks and mount points.
-          (apply invoke "mksquashfs"
-                 `(".empty"
-                   ,#$output
-                   ;; Create SYMLINKS via pseudo file definitions.
-                   ,@(append-map
-                      (match-lambda
-                        ((source '-> target)
-                         ;; Create relative symlinks to work around a bug in
-                         ;; Singularity 2.x:
-                         ;;   https://bugs.gnu.org/34913
-                         ;;   https://github.com/sylabs/singularity/issues/1487
-                         (let ((target (string-append #$profile "/" target)))
-                           (list "-p"
-                                 (string-join
-                                  ;; name s mode uid gid symlink
-                                  (list source
-                                        "s" "777" "0" "0"
-                                        (relative-file-name (dirname source)
-                                                            target)))))))
-                      '#$symlinks*)
-
-                   "-p" "/.singularity.d d 555 0 0"
-
-                   ;; Create the environment file.
-                   "-p" "/.singularity.d/env d 555 0 0"
-                   "-p" ,(string-append
-                          "/.singularity.d/env/90-environment.sh s 777 0 0 "
-                          (relative-file-name "/.singularity.d/env"
-                                              #$environment))
-
-                   ;; Create /.singularity.d/actions, and optionally the 'run'
-                   ;; script, used by 'singularity run'.
-                   "-p" "/.singularity.d/actions d 555 0 0"
-
-                   ,@(if entry-point
-                         `(;; This one if for Singularity 2.x.
-                           "-p"
-                           ,(string-append
-                             "/.singularity.d/actions/run s 777 0 0 "
-                             (relative-file-name "/.singularity.d/actions"
-                                                 (string-append #$profile "/"
-                                                                entry-point)))
-
-                           ;; This one is for Singularity 3.x.
-                           "-p"
-                           ,(string-append
-                             "/.singularity.d/runscript s 777 0 0 "
-                             (relative-file-name "/.singularity.d"
-                                                 (string-append #$profile "/"
-                                                                entry-point))))
-                         '())
-
-                   ;; Create empty mount points.
-                   "-p" "/proc d 555 0 0"
-                   "-p" "/sys d 555 0 0"
-                   "-p" "/dev d 555 0 0"
-                   "-p" "/home d 555 0 0"))
+          (mksquashfs
+           `(".empty"
+             ,#$output
+             ;; Create SYMLINKS via pseudo file definitions.
+             ,@(append-map
+                (match-lambda
+                  ((source '-> target)
+                   ;; Create relative symlinks to work around a bug in
+                   ;; Singularity 2.x:
+                   ;;   https://bugs.gnu.org/34913
+                   ;;   https://github.com/sylabs/singularity/issues/1487
+                   (let ((target (string-append #$profile "/" target)))
+                     (list "-p"
+                           (string-join
+                            ;; name s mode uid gid symlink
+                            (list source
+                                  "s" "777" "0" "0"
+                                  (relative-file-name (dirname source)
+                                                      target)))))))
+                '#$symlinks*)
+
+             "-p" "/.singularity.d d 555 0 0"
+
+             ;; Create the environment file.
+             "-p" "/.singularity.d/env d 555 0 0"
+             "-p" ,(string-append
+                    "/.singularity.d/env/90-environment.sh s 777 0 0 "
+                    (relative-file-name "/.singularity.d/env"
+                                        #$environment))
+
+             ;; Create /.singularity.d/actions, and optionally the 'run'
+             ;; script, used by 'singularity run'.
+             "-p" "/.singularity.d/actions d 555 0 0"
+
+             ,@(if entry-point
+                   `(;; This one if for Singularity 2.x.
+                     "-p"
+                     ,(string-append
+                       "/.singularity.d/actions/run s 777 0 0 "
+                       (relative-file-name "/.singularity.d/actions"
+                                           (string-append #$profile "/"
+                                                          entry-point)))
+
+                     ;; This one is for Singularity 3.x.
+                     "-p"
+                     ,(string-append
+                       "/.singularity.d/runscript s 777 0 0 "
+                       (relative-file-name "/.singularity.d"
+                                           (string-append #$profile "/"
+                                                          entry-point))))
+                   '())
+
+             ;; Create empty mount points.
+             "-p" "/proc d 555 0 0"
+             "-p" "/sys d 555 0 0"
+             "-p" "/dev d 555 0 0"
+             "-p" "/home d 555 0 0"))
 
           (when database
             ;; Initialize /var/guix.
             (install-database-and-gc-roots "var-etc" database #$profile)
-            (invoke "mksquashfs" "var-etc" #$output)))))
+            (mksquashfs `("var-etc" ,#$output))))))
 
   (gexp->derivation (string-append name
                                    (compressor-extension compressor)
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 629844768a..a9e0cba92a 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -175,8 +175,11 @@ about the derivations queued, as is the case with Hydra."
       #f                                          ;no derivation information
       (lset-intersection string=? queued items)))
 
-(define (report-server-coverage server items)
-  "Report the subset of ITEMS available as substitutes on SERVER."
+(define* (report-server-coverage server items
+                                 #:key display-missing?)
+  "Report the subset of ITEMS available as substitutes on SERVER.
+When DISPLAY-MISSING? is true, display the list of missing substitutes.
+Return the coverage ratio, an exact number between 0 and 1."
   (define MiB (* (expt 2 20) 1.))
 
   (format #t (G_ "looking for ~h store items on ~a...~%")
@@ -260,7 +263,16 @@ are queued~%")
                                system
                                (* (throughput builds build-timestamp)
                                   3600.))))
-                    (histogram build-system cons '() latest)))))))
+                    (histogram build-system cons '() latest))))
+
+      (when (and display-missing? (not (null? missing)))
+        (newline)
+        (format #t (G_ "Substitutes are missing for the following items:~%"))
+        (format #t "~{  ~a~%~}" missing))
+
+      ;; Return the coverage ratio.
+      (let ((total (length items)))
+        (/ (- total (length missing)) total)))))
 
 
 ;;;
@@ -281,6 +293,8 @@ Report the availability of substitutes.\n"))
                          show substitute coverage for packages with at least
                          COUNT dependents"))
   (display (G_ "
+      --display-missing  display the list of missing substitutes"))
+  (display (G_ "
   -s, --system=SYSTEM    consider substitutes for SYSTEM--e.g., \"i686-linux\""))
   (newline)
   (display (G_ "
@@ -318,6 +332,9 @@ Report the availability of substitutes.\n"))
                    (alist-cons 'coverage
                                (if arg (string->number* arg) 0)
                                result)))
+         (option '("display-missing") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'display-missing? #t result)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg result)))))
@@ -487,17 +504,19 @@ SERVER.  Display information for packages with at least THRESHOLD dependents."
 (define (guix-weather . args)
   (define (package-list opts)
     ;; Return the package list specified by OPTS.
-    (let ((file (assoc-ref opts 'manifest))
-          (base (filter-map (match-lambda
-                              (('argument . spec)
-                               (specification->package spec))
-                              (_
-                               #f))
-                            opts)))
-      (if (and (not file) (null? base))
+    (let ((files (filter-map (match-lambda
+                               (('manifest . file) file)
+                               (_ #f))
+                             opts))
+          (base  (filter-map (match-lambda
+                               (('argument . spec)
+                                (specification->package spec))
+                               (_
+                                #f))
+                             opts)))
+      (if (and (null? files) (null? base))
           (all-packages)
-          (append base
-                  (if file (load-manifest file) '())))))
+          (append base (append-map load-manifest files)))))
 
   (with-error-handling
     (parameterize ((current-terminal-columns (terminal-columns))
@@ -524,14 +543,24 @@ SERVER.  Display information for packages with at least THRESHOLD dependents."
                                   (lambda (system)
                                     (package-outputs packages system))
                                   systems))))))
-        (for-each (lambda (server)
-                    (report-server-coverage server items)
-                    (match (assoc-ref opts 'coverage)
-                      (#f #f)
-                      (threshold
-                       (report-package-coverage server packages systems
-                                                #:threshold threshold))))
-                  urls)))))
+        (exit
+         (every (lambda (server)
+                  (define coverage
+                    (report-server-coverage server items
+                                            #:display-missing?
+                                            (assoc-ref opts 'display-missing?)))
+                  (match (assoc-ref opts 'coverage)
+                    (#f #f)
+                    (threshold
+                     ;; PACKAGES may include non-package objects coming from a
+                     ;; manifest.  Filter them out.
+                     (report-package-coverage server
+                                              (filter package? packages)
+                                              systems
+                                              #:threshold threshold)))
+
+                  (= 1 coverage))
+                urls))))))
 
 ;;; Local Variables:
 ;;; eval: (put 'let/time 'scheme-indent-function 1)
diff --git a/guix/ui.scm b/guix/ui.scm
index fbe2b70485..6f1ca9c0b2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1218,16 +1218,23 @@ converted to a space; sequences of more than one line break are preserved."
 ;;;
 
 (define %text-width
-  (make-parameter (terminal-columns)))
-
-(set! (@@ (texinfo plain-text) wrap*)
-      ;; XXX: Monkey patch this private procedure to let 'package->recutils'
-      ;; parameterize the fill of description field correctly.
-      (lambda strings
-        (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
-          (fill-string (string-concatenate strings)
-                       #:line-width (%text-width) #:initial-indent indent
-                       #:subsequent-indent indent))))
+  ;; '*line-width*' was introduced in Guile 2.2.7/3.0.1.  On older versions of
+  ;; Guile, monkey-patch 'wrap*' below.
+  (if (defined? '*line-width*)
+      (let ((parameter (fluid->parameter *line-width*)))
+        (parameter (terminal-columns))
+        parameter)
+      (make-parameter (terminal-columns))))
+
+(unless (defined? '*line-width*)                  ;Guile < 2.2.7
+  (set! (@@ (texinfo plain-text) wrap*)
+    ;; XXX: Monkey patch this private procedure to let 'package->recutils'
+    ;; parameterize the fill of description field correctly.
+    (lambda strings
+      (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
+        (fill-string (string-concatenate strings)
+                     #:line-width (%text-width) #:initial-indent indent
+                     #:subsequent-indent indent)))))
 
 (define (texi->plain-text str)
   "Return a plain-text representation of texinfo fragment STR."