summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/r.scm20
-rw-r--r--guix/channels.scm28
-rw-r--r--guix/derivations.scm6
-rw-r--r--guix/import/cran.scm46
-rw-r--r--guix/import/gnome.scm35
-rw-r--r--guix/remote.scm72
-rw-r--r--guix/scripts/deploy.scm25
-rw-r--r--guix/scripts/describe.scm27
-rw-r--r--guix/scripts/refresh.scm45
-rw-r--r--guix/ssh.scm56
-rw-r--r--guix/upstream.scm9
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))))))