Merge branch 'master' into core-updates

11 files changed, 238 insertions, 131 deletions

diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm
index e7214155be..dd2a9fe8de 100644
--- a/guix/build-system/r.scm
+++ b/guix/build-system/r.scm
@@ -47,14 +47,22 @@ available via the first URI, the second URI points to the archived version."
         (string-append "mirror://cran/src/contrib/Archive/"
                        name "/" name "_" version ".tar.gz")))
 
-(define (bioconductor-uri name version)
+(define* (bioconductor-uri name version #:optional type)
   "Return a URI string for the R package archive on Bioconductor for the
 release corresponding to NAME and VERSION."
-  (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/"
-                       name "_" version ".tar.gz")
-        ;; TODO: use %bioconductor-version from (guix import cran)
-        (string-append "https://bioconductor.org/packages/3.9/bioc/src/contrib/Archive/"
-                       name "_" version ".tar.gz")))
+  (let ((type-url-part (match type
+                         ('annotation "/data/annotation")
+                         ('experiment "/data/experiment")
+                         (_ "/bioc"))))
+    (list (string-append "https://bioconductor.org/packages/release"
+                         type-url-part
+                         "/src/contrib/"
+                         name "_" version ".tar.gz")
+          ;; TODO: use %bioconductor-version from (guix import cran)
+          (string-append "https://bioconductor.org/packages/3.9"
+                         type-url-part
+                         "/src/contrib/Archive/"
+                         name "_" version ".tar.gz"))))
 
 (define %r-build-system-modules
   ;; Build-side modules imported by default.
diff --git a/guix/channels.scm b/guix/channels.scm
index 415246cbd1..ebb2cacbc7 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -65,7 +65,9 @@
             latest-channel-derivation
             channel-instances->manifest
             %channel-profile-hooks
-            channel-instances->derivation))
+            channel-instances->derivation
+
+            profile-channels))
 
 ;;; Commentary:
 ;;;
@@ -534,3 +536,27 @@ channel instances."
 latest instances of CHANNELS."
   (mlet %store-monad ((instances (latest-channel-instances* channels)))
     (channel-instances->derivation instances)))
+
+(define (profile-channels profile)
+  "Return the list of channels corresponding to entries in PROFILE.  If
+PROFILE is not a profile created by 'guix pull', return the empty list."
+  (filter-map (lambda (entry)
+                (match (assq 'source (manifest-entry-properties entry))
+                  (('source ('repository ('version 0)
+                                         ('url url)
+                                         ('branch branch)
+                                         ('commit commit)
+                                         _ ...))
+                   (channel (name (string->symbol
+                                   (manifest-entry-name entry)))
+                            (url url)
+                            (commit commit)))
+
+                  ;; No channel information for this manifest entry.
+                  ;; XXX: Pre-0.15.0 Guix did not provide that information,
+                  ;; but there's not much we can do in that case.
+                  (_ #f)))
+
+              ;; Show most recently installed packages last.
+              (reverse
+               (manifest-entries (profile-manifest profile)))))
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 92d50503ce..e1073ea39b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -376,8 +376,8 @@ of SUBSTITUTABLES."
                                  (substitution-oracle
                                   store inputs #:mode mode)))
   "Given INPUTS, a list of derivation-inputs, return two values: the list of
-derivation to build, and the list of substitutable items that, together,
-allows INPUTS to be realized.
+derivations to build, and the list of substitutable items that, together,
+allow INPUTS to be realized.
 
 SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
 by 'substitution-oracle'."
@@ -685,7 +685,7 @@ name of each input with that input's hash."
                              (make-derivation-input hash sub-drvs))))
                         inputs)))
        (make-derivation outputs
-                        (sort inputs
+                        (sort (delete-duplicates inputs)
                               (lambda (drv1 drv2)
                                 (string<? (derivation-input-derivation drv1)
                                           (derivation-input-derivation drv2))))
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 3240094444..9c964701b1 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -132,14 +132,19 @@ package definition."
 ;; updated together.
 (define %bioconductor-version "3.9")
 
-(define %bioconductor-packages-list-url
+(define* (bioconductor-packages-list-url #:optional type)
   (string-append "https://bioconductor.org/packages/"
-                 %bioconductor-version "/bioc/src/contrib/PACKAGES"))
-
-(define (bioconductor-packages-list)
+                 %bioconductor-version
+                 (match type
+                   ('annotation "/data/annotation")
+                   ('experiment "/data/experiment")
+                   (_ "/bioc"))
+                 "/src/contrib/PACKAGES"))
+
+(define* (bioconductor-packages-list #:optional type)
   "Return the latest version of package NAME for the current bioconductor
 release."
-  (let ((url (string->uri %bioconductor-packages-list-url)))
+  (let ((url (string->uri (bioconductor-packages-list-url type))))
     (guard (c ((http-get-error? c)
                (format (current-error-port)
                        "error: failed to retrieve list of packages from ~s: ~a (~s)~%"
@@ -153,12 +158,12 @@ release."
              (description->alist (string-join chunk "\n")))
            (chunk-lines (read-lines (http-fetch/cached url)))))))
 
-(define (latest-bioconductor-package-version name)
+(define* (latest-bioconductor-package-version name #:optional type)
   "Return the version string corresponding to the latest release of the
 bioconductor package NAME, or #F if the package is unknown."
   (and=> (find (lambda (meta)
                  (string=? (assoc-ref meta "Package") name))
-               (bioconductor-packages-list))
+               (bioconductor-packages-list type))
          (cut assoc-ref <> "Version")))
 
 ;; Little helper to download URLs only once.
@@ -187,8 +192,12 @@ from ~s: ~a (~s)~%"
      ;; Currently, the bioconductor project does not offer a way to access a
      ;; package's DESCRIPTION file over HTTP, so we determine the version,
      ;; download the source tarball, and then extract the DESCRIPTION file.
-     (and-let* ((version (latest-bioconductor-package-version name))
-                (url     (car (bioconductor-uri name version)))
+     (and-let* ((type    (or
+                          (and (latest-bioconductor-package-version name) #t)
+                          (and (latest-bioconductor-package-version name 'annotation) 'annotation)
+                          (and (latest-bioconductor-package-version name 'experiment) 'experiment)))
+                (version (latest-bioconductor-package-version name type))
+                (url     (car (bioconductor-uri name version type)))
                 (tarball (download url)))
        (call-with-temporary-directory
         (lambda (dir)
@@ -198,8 +207,11 @@ from ~s: ~a (~s)~%"
                                  "--strip-components=1"
                                  "-C" dir
                                  "-f" tarball "*/DESCRIPTION"))
-                 (description->alist (with-input-from-file
-                                         (string-append dir "/DESCRIPTION") read-string))))))))))
+                 (and=> (description->alist (with-input-from-file
+                                                (string-append dir "/DESCRIPTION") read-string))
+                        (lambda (meta)
+                          (if (boolean? type) meta
+                              (cons `(bioconductor-type . ,type) meta))))))))))))
 
 (define (listify meta field)
   "Look up FIELD in the alist META.  If FIELD contains a comma-separated
@@ -306,7 +318,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
          (home-page  (match (listify meta "URL")
                        ((url rest ...) url)
                        (_ (string-append base-url name))))
-         (source-url (match (uri-helper name version)
+         (source-url (match (apply uri-helper name version
+                                   (case repository
+                                     ((bioconductor)
+                                      (list (assoc-ref meta 'bioconductor-type)))
+                                     (else '())))
                        ((url rest ...) url)
                        ((? string? url) url)
                        (_ #f)))
@@ -330,7 +346,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
         (version ,version)
         (source (origin
                   (method url-fetch)
-                  (uri (,(procedure-name uri-helper) ,name version))
+                  (uri (,(procedure-name uri-helper) ,name version
+                        ,@(or (and=> (assoc-ref meta 'bioconductor-type)
+                                     (lambda (type)
+                                       (list (list 'quote type))))
+                              '())))
                   (sha256
                    (base32
                     ,(bytevector->nix-base32-string (file-sha256 tarball))))))
diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm
index 1ade63e1af..436ec88ef9 100644
--- a/guix/import/gnome.scm
+++ b/guix/import/gnome.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -46,7 +46,7 @@ source for metadata."
       (package name)
       (version version)
       (urls (filter-map (lambda (extension)
-                          (match (hash-ref dictionary extension)
+                          (match (assoc-ref dictionary extension)
                             (#f
                              #f)
                             ((? string? relative-url)
@@ -86,21 +86,22 @@ not be determined."
            (json (json->scm port)))
       (close-port port)
       (match json
-        ((4 (? hash-table? releases) _ ...)
-         (let* ((releases (hash-ref releases upstream-name))
-                (latest   (hash-fold (lambda (key value result)
-                                       (cond ((even-minor-version? key)
-                                              (match result
-                                                (#f
-                                                 (cons key value))
-                                                ((newest . _)
-                                                 (if (version>? key newest)
-                                                     (cons key value)
-                                                     result))))
-                                             (else
-                                              result)))
-                                     #f
-                                     releases)))
+        (#(4 releases _ ...)
+         (let* ((releases (assoc-ref releases upstream-name))
+                (latest   (fold (match-lambda*
+                                  (((key . value) result)
+                                   (cond ((even-minor-version? key)
+                                          (match result
+                                            (#f
+                                             (cons key value))
+                                            ((newest . _)
+                                             (if (version>? key newest)
+                                                 (cons key value)
+                                                 result))))
+                                         (else
+                                          result))))
+                                #f
+                                releases)))
            (and latest
                 (jsonish->upstream-source upstream-name latest))))))))
 
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..d0c3d04a25 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -19,13 +19,17 @@
 (define-module (guix remote)
   #:use-module (guix ssh)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix inferior)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix modules)
   #:use-module (guix derivations)
+  #:use-module (guix utils)
   #:use-module (ssh popen)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (remote-eval))
 
@@ -40,29 +44,41 @@
 ;;;
 ;;; Code:
 
-(define (remote-pipe-for-gexp lowered session)
-  "Return a remote pipe for the given SESSION to evaluate LOWERED."
+(define* (remote-pipe-for-gexp lowered session #:optional become-command)
+  "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
   (define shell-quote
     (compose object->string object->string))
 
-  (apply open-remote-pipe* session OPEN_READ
-         (string-append (derivation-input-output-path
-                         (lowered-gexp-guile lowered))
-                        "/bin/guile")
-         "--no-auto-compile"
-         (append (append-map (lambda (directory)
-                               `("-L" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 (append-map (lambda (directory)
-                               `("-C" ,directory))
-                             (lowered-gexp-load-path lowered))
-                 `("-c"
-                   ,(shell-quote (lowered-gexp-sexp lowered))))))
+  (define repl-command
+    (append (or become-command '())
+            (list
+             (string-append (derivation-input-output-path
+                             (lowered-gexp-guile lowered))
+                            "/bin/guile")
+             "--no-auto-compile")
+            (append-map (lambda (directory)
+                          `("-L" ,directory))
+                        (lowered-gexp-load-path lowered))
+            (append-map (lambda (directory)
+                          `("-C" ,directory))
+                        (lowered-gexp-load-path lowered))
+            `("-c"
+              ,(shell-quote (lowered-gexp-sexp lowered)))))
 
-(define (%remote-eval lowered session)
+  (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
+    pipe))
+
+(define* (%remote-eval lowered session #:optional become-command)
   "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
-prerequisites of EXP are already available on the host at SESSION."
-  (let* ((pipe   (remote-pipe-for-gexp lowered session))
+prerequisites of EXP are already available on the host at SESSION.  If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
+  (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
          (result (read-repl-response pipe)))
     (close-port pipe)
     result))
@@ -71,7 +87,7 @@ prerequisites of EXP are already available on the host at SESSION."
   "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
 result to the current output port using the (guix repl) protocol."
   (define program
-    (scheme-file "remote-exp.scm" exp))
+    (program-file "remote-exp.scm" exp))
 
   (with-imported-modules (source-module-closure '((guix repl)))
     #~(begin
@@ -89,17 +105,21 @@ result to the current output port using the (guix repl) protocol."
 (define* (remote-eval exp session
                       #:key
                       (build-locally? #t)
+                      (system (%current-system))
                       (module-path %load-path)
-                      (socket-name "/var/guix/daemon-socket/socket"))
+                      (socket-name (%daemon-socket-uri))
+                      (become-command #f))
   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 all the elements EXP refers to are built and deployed to SESSION beforehand.
 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
 the remote store afterwards; otherwise, dependencies are built directly on the
 remote store."
-  (mlet %store-monad ((lowered (lower-gexp (trampoline exp)
-                                           #:module-path %load-path))
-                      (remote -> (connect-to-remote-daemon session
-                                                           socket-name)))
+  (mlet* %store-monad ((lowered (lower-gexp (trampoline exp)
+                                            #:system system
+                                            #:guile-for-build #f
+                                            #:module-path %load-path))
+                       (remote -> (connect-to-remote-daemon session
+                                                            socket-name)))
     (define inputs
       (cons (lowered-gexp-guile lowered)
             (lowered-gexp-inputs lowered)))
@@ -115,7 +135,7 @@ remote store."
             (built-derivations inputs)
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (close-connection remote))
-            (return (%remote-eval lowered session))))
+            (return (%remote-eval lowered session become-command))))
         (let ((to-send (append (map (compose derivation-file-name
                                              derivation-input-derivation)
                                     inputs)
@@ -124,4 +144,4 @@ remote store."
             ((store-lift send-files) to-send remote #:recursive? #t)
             (return (build-derivations remote inputs))
             (return (close-connection remote))
-            (return (%remote-eval lowered session)))))))
+            (return (%remote-eval lowered session become-command)))))))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index ebc99e52cc..6a67985c8b 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,8 @@
   #:use-module (guix grafts)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:export (guix-deploy))
 
@@ -43,8 +45,6 @@
 (define (show-help)
   (display (G_ "Usage: guix deploy [OPTION] FILE...
 Perform the deployment specified by FILE.\n"))
-  (display (G_ "
-  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
   (show-build-options-help)
   (newline)
   (display (G_ "
@@ -66,8 +66,7 @@ Perform the deployment specified by FILE.\n"))
          %standard-build-options))
 
 (define %default-options
-  `((system . ,(%current-system))
-    (substitutes? . #t)
+  `((substitutes? . #t)
     (build-hook? . #t)
     (graft? . #t)
     (debug . 0)
@@ -91,8 +90,18 @@ Perform the deployment specified by FILE.\n"))
     (with-store store
       (set-build-options-from-command-line store opts)
       (for-each (lambda (machine)
-                  (info (G_ "deploying to ~a...") (machine-display-name machine))
-                  (parameterize ((%current-system (assq-ref opts 'system))
-                                 (%graft? (assq-ref opts 'graft?)))
-                    (run-with-store store (deploy-machine machine))))
+                  (info (G_ "deploying to ~a...~%")
+                        (machine-display-name machine))
+                  (parameterize ((%graft? (assq-ref opts 'graft?)))
+                    (guard (c ((message-condition? c)
+                               (report-error (G_ "failed to deploy ~a: '~a'~%")
+                                             (machine-display-name machine)
+                                             (condition-message c)))
+                              ((deploy-error? c)
+                               (when (deploy-error-should-roll-back c)
+                                 (info (G_ "rolling back ~a...~%")
+                                       (machine-display-name machine))
+                                 (run-with-store store (roll-back-machine machine)))
+                               (apply throw (deploy-error-captured-args c))))
+                      (run-with-store store (deploy-machine machine)))))
                 machines))))
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index fa6b6cae37..99a88c50fa 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -153,30 +153,9 @@ in the format specified by FMT."
     (generation-number profile))
 
   (define channels
-    (map (lambda (entry)
-           (match (assq 'source (manifest-entry-properties entry))
-             (('source ('repository ('version 0)
-                                    ('url url)
-                                    ('branch branch)
-                                    ('commit commit)
-                                    _ ...))
-              (channel (name (string->symbol (manifest-entry-name entry)))
-                       (url url)
-                       (commit commit)))
-
-             ;; Pre-0.15.0 Guix does not provide that information,
-             ;; so there's not much we can do in that case.
-             (_ (channel (name 'guix)
-                         (url "?")
-                         (commit "?")))))
-
-         ;; Show most recently installed packages last.
-         (reverse
-          (manifest-entries
-           (profile-manifest
-            (if (zero? number)
-                profile
-                (generation-file-name profile number)))))))
+    (profile-channels (if (zero? number)
+                          profile
+                          (generation-file-name profile number))))
 
   (match fmt
     ('human
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index dd7026a6a4..4591d0f308 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -285,10 +285,9 @@ update would trigger a complete rebuild."
   (exit 0))
 
 (define (warn-no-updater package)
-  (format (current-error-port)
-          (G_ "~a: warning: no updater for ~a~%")
-          (location->string (package-location package))
-          (package-name package)))
+  (warning (package-location package)
+           (G_ "no updater for ~a~%")
+           (package-name package)))
 
 (define* (update-package store package updaters
                          #:key (key-download 'interactive) warn?)
@@ -306,11 +305,10 @@ warn about packages that have no matching updater."
         (when version
           (if (and=> tarball file-exists?)
               (begin
-                (format (current-error-port)
-                        (G_ "~a: ~a: updating from version ~a to version ~a...~%")
-                        (location->string loc)
-                        (package-name package)
-                        (package-version package) version)
+                (info loc
+                      (G_ "~a: updating from version ~a to version ~a...~%")
+                      (package-name package)
+                      (package-version package) version)
                 (for-each
                  (lambda (change)
                    (format (current-error-port)
@@ -350,27 +348,24 @@ WARN? is true and no updater exists for PACKAGE, print a warning."
        (case (version-compare (upstream-source-version source)
                               (package-version package))
          ((>)
-          (format (current-error-port)
-                  (G_ "~a: ~a would be upgraded from ~a to ~a~%")
-                  (location->string loc)
-                  (package-name package) (package-version package)
-                  (upstream-source-version source)))
+          (info loc
+                (G_ "~a would be upgraded from ~a to ~a~%")
+                (package-name package) (package-version package)
+                (upstream-source-version source)))
          ((=)
           (when warn?
-            (format (current-error-port)
-                    (G_ "~a: info: ~a is already the latest version of ~a~%")
-                    (location->string loc)
-                    (package-version package)
-                    (package-name package))))
+            (info loc
+                  (G_ "~a is already the latest version of ~a~%")
+                  (package-version package)
+                  (package-name package))))
          (else
           (when warn?
-            (format (current-error-port)
-                    (G_ "~a: warning: ~a is greater than \
+            (warning loc
+                     (G_ "~a is greater than \
 the latest known version of ~a (~a)~%")
-                    (location->string loc)
-                    (package-version package)
-                    (package-name package)
-                    (upstream-source-version source)))))))
+                     (package-version package)
+                     (package-name package)
+                     (upstream-source-version source)))))))
     (#f
      (when warn?
        (warn-no-updater package)))))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ede00133c8..7bc499a2fe 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -21,6 +21,7 @@
   #:use-module (guix inferior)
   #:use-module (guix i18n)
   #:use-module ((guix utils) #:select (&fix-hint))
+  #:use-module (gcrypt pk-crypto)
   #:use-module (ssh session)
   #:use-module (ssh auth)
   #:use-module (ssh key)
@@ -39,6 +40,8 @@
             remote-inferior
             remote-daemon-channel
             connect-to-remote-daemon
+            remote-system
+            remote-authorize-signing-key
             send-files
             retrieve-files
             retrieve-files*
@@ -97,16 +100,27 @@ specifies; otherwise use them.  Throw an error on failure."
                 (message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
                                  host (get-error session))))))))))
 
-(define (remote-inferior session)
-  "Return a remote inferior for the given SESSION."
-  (let ((pipe (open-remote-pipe* session OPEN_BOTH
-                                 "guix" "repl" "-t" "machine")))
+(define* (remote-inferior session #:optional become-command)
+  "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
+given, use that to invoke the remote Guile REPL."
+  (let* ((repl-command (append (or become-command '())
+                               '("guix" "repl" "-t" "machine")))
+         (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
+    ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the
+    ;; process does succeed. This doesn't reflect the documentation, so it's
+    ;; possible that it's a bug in guile-ssh.
+    (when (eof-object? (peek-char pipe))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "failed to run '~{~a~^ ~}'")
+                                repl-command))))))
     (port->inferior pipe)))
 
-(define (inferior-remote-eval exp session)
+(define* (inferior-remote-eval exp session #:optional become-command)
   "Evaluate EXP in a new inferior running in SESSION, and close the inferior
-right away."
-  (let ((inferior (remote-inferior session)))
+right away.  If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
+  (let ((inferior (remote-inferior session become-command)))
     (dynamic-wind
       (const #t)
       (lambda ()
@@ -282,6 +296,34 @@ be read.  When RECURSIVE? is true, the closure of FILES is exported."
                              ,(object->string
                                (object->string export))))))
 
+(define (remote-system session)
+  "Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of
+the machine on the other end of SESSION."
+  (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
+                        session))
+
+(define* (remote-authorize-signing-key key session #:optional become-command)
+  "Send KEY, a canonical sexp containing a public key, over SESSION and add it
+to the system ACL file if it has not yet been authorized."
+  (inferior-remote-eval
+   `(begin
+      (use-modules (guix build utils)
+                   (guix pki)
+                   (guix utils)
+                   (gcrypt pk-crypto)
+                   (srfi srfi-26))
+
+      (define acl (current-acl))
+      (define key (string->canonical-sexp ,(canonical-sexp->string key)))
+
+      (unless (authorized-key? key)
+        (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
+          (mkdir-p (dirname %acl-file))
+          (with-atomic-file-output %acl-file
+            (cut write-acl acl <>)))))
+   session
+   become-command))
+
 (define* (send-files local files remote
                      #:key
                      recursive?
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 1326b3db95..d4f9c5bb45 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -362,6 +362,7 @@ SOURCE, an <upstream-source>."
                       (_
                        "gz")))
                    ((url signature-url)
+                    ;; Try to find a URL that matches ARCHIVE-TYPE.
                     (find2 (lambda (url sig-url)
                              ;; Some URIs lack a file extension, like
                              ;; 'https://crates.io/???/0.1/download'.  In that
@@ -370,7 +371,13 @@ SOURCE, an <upstream-source>."
                                  (string-suffix? archive-type url)))
                            urls
                            (or signature-urls (circular-list #f)))))
-       (let ((tarball (download-tarball store url signature-url
+       ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
+       ;; pick up the first element of URLS.
+       (let ((tarball (download-tarball store
+                                        (or url (first urls))
+                                        (and (pair? signature-urls)
+                                             (or signature-url
+                                                 (first signature-urls)))
                                         #:key-download key-download)))
          (values version tarball source))))))