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/packages.scm3
-rw-r--r--guix/remote.scm1
-rw-r--r--guix/scripts/describe.scm27
-rw-r--r--guix/scripts/pack.scm49
-rw-r--r--guix/scripts/refresh.scm45
-rw-r--r--guix/ssh.scm5
-rw-r--r--guix/swh.scm31
-rw-r--r--guix/upstream.scm9
13 files changed, 182 insertions, 123 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/packages.scm b/guix/packages.scm
index c94a651f27..143417b861 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -796,7 +796,8 @@ dependencies are known to build on SYSTEM."
(define (bag-transitive-host-inputs bag)
"Same as 'package-transitive-target-inputs', but applied to a bag."
- (transitive-inputs (bag-host-inputs bag)))
+ (parameterize ((%current-target-system (bag-target bag)))
+ (transitive-inputs (bag-host-inputs bag))))
(define (bag-transitive-target-inputs bag)
"Return the \"target inputs\" of BAG, recursively."
diff --git a/guix/remote.scm b/guix/remote.scm
index ae2fe17dd2..d0c3d04a25 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -19,6 +19,7 @@
(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)
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/pack.scm b/guix/scripts/pack.scm
index fdb98983bf..794d2ee390 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -611,8 +611,13 @@ please email '~a'~%")
;;;
(define* (wrapped-package package
- #:optional (compiler (c-compiler))
+ #:optional
+ (output* "out")
+ (compiler (c-compiler))
#:key proot?)
+ "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
+relocatable. When PROOT? is true, include PRoot in the result and use it as a
+last resort for relocation."
(define runner
(local-file (search-auxiliary-file "run-in-namespace.c")))
@@ -629,6 +634,14 @@ please email '~a'~%")
(ice-9 ftw)
(ice-9 match))
+ (define input
+ ;; The OUTPUT* output of PACKAGE.
+ (ungexp package output*))
+
+ (define target
+ ;; The output we are producing.
+ (ungexp output output*))
+
(define (strip-store-prefix file)
;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
;; "/bin/foo".
@@ -648,7 +661,7 @@ please email '~a'~%")
(("@STORE_DIRECTORY@") (%store-directory)))
(let* ((base (strip-store-prefix program))
- (result (string-append #$output "/" base))
+ (result (string-append target "/" base))
(proot #$(and proot?
#~(string-drop
#$(file-append (proot) "/bin/proot")
@@ -667,18 +680,18 @@ please email '~a'~%")
;; Link the top-level files of PACKAGE so that search paths are
;; properly defined in PROFILE/etc/profile.
- (mkdir #$output)
+ (mkdir target)
(for-each (lambda (file)
(unless (member file '("." ".." "bin" "sbin" "libexec"))
- (let ((file* (string-append #$package "/" file)))
- (symlink (relative-file-name #$output file*)
- (string-append #$output "/" file)))))
- (scandir #$package))
+ (let ((file* (string-append input "/" file)))
+ (symlink (relative-file-name target file*)
+ (string-append target "/" file)))))
+ (scandir input))
(for-each build-wrapper
- (append (find-files #$(file-append package "/bin"))
- (find-files #$(file-append package "/sbin"))
- (find-files #$(file-append package "/libexec")))))))
+ (append (find-files (string-append input "/bin"))
+ (find-files (string-append input "/sbin"))
+ (find-files (string-append input "/libexec")))))))
(computed-file (string-append
(cond ((package? package)
@@ -691,14 +704,18 @@ please email '~a'~%")
"R")
build))
+(define (wrapped-manifest-entry entry . args)
+ (manifest-entry
+ (inherit entry)
+ (item (apply wrapped-package
+ (manifest-entry-item entry)
+ (manifest-entry-output entry)
+ args))))
+
(define (map-manifest-entries proc manifest)
"Apply PROC to all the entries of MANIFEST and return a new manifest."
(make-manifest
- (map (lambda (entry)
- (manifest-entry
- (inherit entry)
- (item (proc (manifest-entry-item entry)))))
- (manifest-entries manifest))))
+ (map proc (manifest-entries manifest))))
;;;
@@ -960,7 +977,7 @@ Create a bundle of PACKAGE.\n"))
;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable?
(map-manifest-entries
- (cut wrapped-package <> #:proot? proot?)
+ (cut wrapped-manifest-entry <> #:proot? proot?)
manifest)
manifest)))
(pack-format (assoc-ref opts 'format))
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 24834c6f68..7bc499a2fe 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -302,7 +302,7 @@ 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)
+(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
@@ -321,7 +321,8 @@ to the system ACL file if it has not yet been authorized."
(mkdir-p (dirname %acl-file))
(with-atomic-file-output %acl-file
(cut write-acl acl <>)))))
- session))
+ session
+ become-command))
(define* (send-files local files remote
#:key
diff --git a/guix/swh.scm b/guix/swh.scm
index df2a138f04..1c416c8dd5 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -547,19 +547,22 @@ wait until it becomes available, which could take several minutes."
((? revision? revision)
(call-with-temporary-directory
(lambda (directory)
- (let ((input (vault-fetch (revision-directory revision) 'directory))
- (tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
- (dump-port input tar)
- (close-port input)
- (let ((status (close-pipe tar)))
- (unless (zero? status)
- (error "tar extraction failure" status)))
-
- (match (scandir directory)
- (("." ".." sub-directory)
- (copy-recursively (string-append directory "/" sub-directory)
- output
- #:log (%make-void-port "w"))
- #t))))))
+ (match (vault-fetch (revision-directory revision) 'directory)
+ (#f
+ #f)
+ ((? port? input)
+ (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
+ (dump-port input tar)
+ (close-port input)
+ (let ((status (close-pipe tar)))
+ (unless (zero? status)
+ (error "tar extraction failure" status)))
+
+ (match (scandir directory)
+ (("." ".." sub-directory)
+ (copy-recursively (string-append directory "/" sub-directory)
+ output
+ #:log (%make-void-port "w"))
+ #t))))))))
(#f
#f)))
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))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-08-02 04:39:10 +0000