summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-11-17 23:24:42 +0100
committerLudovic Courtès <ludo@gnu.org>2021-11-17 23:43:14 +0100
commit3a317f7476f8c6012e166ff9f340f861938721c9 (patch)
tree946e398c37912cfc03be7306951ae87bfeb130fa /guix
parente55547bf70384691712047912c793c517debd2ec (diff)
parent62e707d67caf1dab2af411a69ff8cec4b2dc686e (diff)
Merge branch 'master' into core-updates-frozen
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/julia.scm5
-rw-r--r--guix/build/julia-build-system.scm48
-rw-r--r--guix/build/qt-utils.scm2
-rw-r--r--guix/import/cran.scm91
-rw-r--r--guix/import/print.scm85
-rw-r--r--guix/import/pypi.scm47
-rw-r--r--guix/import/utils.scm3
-rw-r--r--guix/licenses.scm2
-rw-r--r--guix/packages.scm2
-rw-r--r--guix/scripts/environment.scm2
-rw-r--r--guix/scripts/import/cran.scm35
-rw-r--r--guix/scripts/import/pypi.scm32
-rw-r--r--guix/store/deduplication.scm69
-rw-r--r--guix/tests.scm30
14 files changed, 312 insertions, 141 deletions
diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm
index 5b824d7f0a..2998663df1 100644
--- a/guix/build-system/julia.scm
+++ b/guix/build-system/julia.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -84,6 +85,7 @@
(system (%current-system))
(guile #f)
(julia-package-name #f)
+ (julia-package-uuid #f)
(imported-modules %julia-build-system-modules)
(modules '((guix build julia-build-system)
(guix build utils))))
@@ -102,7 +104,8 @@
(map search-path-specification->sexp
search-paths))
#:inputs #$(input-tuples->gexp inputs)
- #:julia-package-name #$julia-package-name))))
+ #:julia-package-name #$julia-package-name
+ #:julia-package-uuid #$julia-package-uuid))))
(mlet %store-monad ((guile (package->derivation (or guile (default-guile))
system #:graft? #f)))
diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm
index d74acf2a05..41c69665c6 100644
--- a/guix/build/julia-build-system.scm
+++ b/guix/build/julia-build-system.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz>
+;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,9 +21,11 @@
(define-module (guix build julia-build-system)
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
#:use-module (guix build utils)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 popen)
#:export (%standard-phases
julia-create-package-toml
julia-build))
@@ -37,7 +40,7 @@
(invoke "julia" "-e" code))
;; subpath where we store the package content
-(define %package-path "/share/julia/packages/")
+(define %package-path "/share/julia/loadpath/")
(define (project.toml->name file)
"Look for Julia package name in the TOML file FILE (usually named
@@ -51,6 +54,18 @@ Project.toml)."
(if m (match:substring m 1)
(loop (read-line in 'concat)))))))))
+(define (project.toml->uuid file)
+ "Look for Julia package uuid in the TOML file FILE (usually named
+Project.toml)."
+ (call-with-input-file file
+ (lambda (in)
+ (let loop ((line (read-line in 'concat)))
+ (if (eof-object? line)
+ #f
+ (let ((m (string-match "uuid\\s*=\\s*\"(.*)\"" line)))
+ (if m (match:substring m 1)
+ (loop (read-line in 'concat)))))))))
+
(define* (install #:key source inputs outputs julia-package-name
#:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
@@ -73,7 +88,7 @@ Project.toml)."
(setenv "JULIA_DEPOT_PATH" builddir)
;; Add new package dir to the load path.
(setenv "JULIA_LOAD_PATH"
- (string-append builddir "packages/" ":"
+ (string-append builddir "loadpath/" ":"
(or (getenv "JULIA_LOAD_PATH")
"")))
;; Actual precompilation:
@@ -97,15 +112,36 @@ Project.toml)."
(setenv "SOURCE_DATE_EPOCH" "1")
(setenv "JULIA_DEPOT_PATH" builddir)
(setenv "JULIA_LOAD_PATH"
- (string-append builddir "packages/" ":"
+ (string-append builddir "loadpath/" ":"
(or (getenv "JULIA_LOAD_PATH")
"")))
(setenv "HOME" "/tmp")
(invoke "julia" "--depwarn=yes"
- (string-append builddir "packages/"
+ (string-append builddir "loadpath/"
package "/test/runtests.jl"))))
#t)
+(define* (link-depot #:key source inputs outputs julia-package-name julia-package-uuid
+ #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (package-name (or
+ julia-package-name
+ (project.toml->name "Project.toml")))
+ (package-dir (string-append out %package-path package-name))
+ (uuid (or julia-package-uuid (project.toml->uuid "Project.toml")))
+ (pipe (open-pipe* OPEN_READ "julia" "-e"
+ (format #f "using Pkg;
+println(Base.version_slug(Base.UUID(\"~a\"),
+ Base.SHA1(Pkg.GitTools.tree_hash(\".\"))))" uuid)))
+ (slug (string-trim-right (get-string-all pipe))))
+ ;; When installing a package, julia looks first at in the JULIA_DEPOT_PATH
+ ;; for a path like packages/PACKAGE/XXXX
+ ;; Where XXXX is a slug encoding the package UUID and SHA1 of the files
+ ;; Here we create a link with the correct path to enable julia to find the package
+ (mkdir-p (string-append out "/share/julia/packages/" package-name))
+ (symlink package-dir (string-append out "/share/julia/packages/" package-name "/" slug)))
+ #t)
+
(define (julia-create-package-toml outputs source
name uuid version
deps)
@@ -138,6 +174,7 @@ version = \"" version "\"
(delete 'check) ; tests must be run after installation
(replace 'install install)
(add-after 'install 'precompile precompile)
+ (add-after 'unpack 'link-depot link-depot)
(add-after 'install 'check check)
;; TODO: In the future we could add a "system-image-generation" phase
;; where we use PackageCompiler.jl to speed up package loading times
@@ -146,11 +183,12 @@ version = \"" version "\"
(delete 'patch-usr-bin-file)
(delete 'build)))
-(define* (julia-build #:key inputs julia-package-name
+(define* (julia-build #:key inputs julia-package-name julia-package-uuid
(phases %standard-phases)
#:allow-other-keys #:rest args)
"Build the given Julia package, applying all of PHASES in order."
(apply gnu:gnu-build
#:inputs inputs #:phases phases
#:julia-package-name julia-package-name
+ #:julia-package-uuid julia-package-uuid
args))
diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm
index e86442b79f..fa018a93ac 100644
--- a/guix/build/qt-utils.scm
+++ b/guix/build/qt-utils.scm
@@ -110,7 +110,7 @@
(define* (wrap-qt-program program-name #:key inputs output
(qt-wrap-excluded-inputs %qt-wrap-excluded-inputs))
- "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\"
+ "Wrap the specified program (which must reside in the OUTPUT's \"/bin\"
directory) with suitably set environment variables.
This is like qt-build-systems's phase \"qt-wrap\", but only the named program
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 420cd3b63a..1389576cad 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -229,26 +229,61 @@ bioconductor package NAME, or #F if the package is unknown."
(let ((store-directory
(add-to-store store (basename url) #t "sha256" dir)))
(values store-directory changeset)))))))
- (else (download-to-store store url)))))))
-
-(define (fetch-description repository name)
+ (else
+ (match url
+ ((? string?)
+ (download-to-store store url))
+ ((urls ...)
+ ;; Try all the URLs. A use case where this is useful is when one
+ ;; of the URLs is the /Archive CRAN URL.
+ (any (cut download-to-store store <>) urls)))))))))
+
+(define (fetch-description-from-tarball url)
+ "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and
+return the resulting alist."
+ (match (download url)
+ (#f #f)
+ (tarball
+ (call-with-temporary-directory
+ (lambda (dir)
+ (parameterize ((current-error-port (%make-void-port "rw+"))
+ (current-output-port (%make-void-port "rw+")))
+ (and (zero? (system* "tar" "--wildcards" "-x"
+ "--strip-components=1"
+ "-C" dir
+ "-f" tarball "*/DESCRIPTION"))
+ (description->alist
+ (call-with-input-file (string-append dir "/DESCRIPTION")
+ read-string)))))))))
+
+(define* (fetch-description repository name #:optional version)
"Return an alist of the contents of the DESCRIPTION file for the R package
-NAME in the given REPOSITORY, or #f in case of failure. NAME is
+NAME at VERSION in the given REPOSITORY, or #f in case of failure. NAME is
case-sensitive."
(case repository
((cran)
- (let ((url (string-append %cran-url name "/DESCRIPTION")))
- (guard (c ((http-get-error? c)
- (warning (G_ "failed to retrieve package information \
+ (guard (c ((http-get-error? c)
+ (warning (G_ "failed to retrieve package information \
from ~a: ~a (~a)~%")
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))
- #f))
- (let* ((port (http-fetch url))
- (result (description->alist (read-string port))))
- (close-port port)
- result))))
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))
+ #f))
+ ;; When VERSION is true, we have to download the tarball to get at its
+ ;; 'DESCRIPTION' file; only the latest one is directly accessible over
+ ;; HTTP.
+ (if version
+ (let ((urls (list (string-append "mirror://cran/src/contrib/"
+ name "_" version ".tar.gz")
+ (string-append "mirror://cran/src/contrib/Archive/"
+ name "/"
+ name "_" version ".tar.gz"))))
+ (fetch-description-from-tarball urls))
+ (let* ((url (string-append %cran-url name "/DESCRIPTION"))
+ (port (http-fetch url))
+ (result (description->alist (read-string port))))
+ (close-port port)
+ result))))
((bioconductor)
;; Currently, the bioconductor project does not offer a way to access a
;; package's DESCRIPTION file over HTTP, so we determine the version,
@@ -257,22 +292,13 @@ from ~a: ~a (~a)~%")
(and (latest-bioconductor-package-version name) #t)
(and (latest-bioconductor-package-version name 'annotation) 'annotation)
(and (latest-bioconductor-package-version name 'experiment) 'experiment)))
+ ;; TODO: Honor VERSION.
(version (latest-bioconductor-package-version name type))
(url (car (bioconductor-uri name version type)))
- (tarball (download url)))
- (call-with-temporary-directory
- (lambda (dir)
- (parameterize ((current-error-port (%make-void-port "rw+"))
- (current-output-port (%make-void-port "rw+")))
- (and (zero? (system* "tar" "--wildcards" "-x"
- "--strip-components=1"
- "-C" dir
- "-f" tarball "*/DESCRIPTION"))
- (and=> (description->alist (with-input-from-file
- (string-append dir "/DESCRIPTION") read-string))
- (lambda (meta)
- (if (boolean? type) meta
- (cons `(bioconductor-type . ,type) meta))))))))))
+ (meta (fetch-description-from-tarball url)))
+ (if (boolean? type)
+ meta
+ (cons `(bioconductor-type . ,type) meta))))
((git)
(and (string-prefix? "http" name)
;; Download the git repository at "NAME"
@@ -485,7 +511,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
((bioconductor)
(list (assoc-ref meta 'bioconductor-type)))
(else '())))
- ((url rest ...) url)
+ ((urls ...) urls)
((? string? url) url)
(_ #f)))))
(git? (assoc-ref meta 'git))
@@ -592,7 +618,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(lambda* (package-name #:key (repo 'cran) version)
"Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
s-expression corresponding to that package, or #f on failure."
- (let ((description (fetch-description repo package-name)))
+ (let ((description (fetch-description repo package-name version)))
(if description
(description->package repo description)
(case repo
@@ -610,8 +636,9 @@ s-expression corresponding to that package, or #f on failure."
(&message
(message "couldn't find meta-data for R package")))))))))))
-(define* (cran-recursive-import package-name #:key (repo 'cran))
+(define* (cran-recursive-import package-name #:key (repo 'cran) version)
(recursive-import package-name
+ #:version version
#:repo repo
#:repo->guix-package cran->guix-package
#:guix-name cran-guix-name))
diff --git a/guix/import/print.scm b/guix/import/print.scm
index c1739f35e3..66016145cb 100644
--- a/guix/import/print.scm
+++ b/guix/import/print.scm
@@ -26,6 +26,7 @@
#:use-module (guix build-system)
#:use-module (gnu packages)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (guix import utils)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
@@ -39,9 +40,6 @@
(_ #f))
inputs))
-;; FIXME: the quasiquoted arguments field may contain embedded package
-;; objects, e.g. in #:disallowed-references; they will just be printed with
-;; their usual #<package ...> representation, not as variable names.
(define (package->code package)
"Return an S-expression representing the source code that produces PACKAGE
when evaluated."
@@ -81,6 +79,11 @@ when evaluated."
(file-type (quote ,(search-path-specification-file-type spec)))
(file-pattern ,(search-path-specification-file-pattern spec))))
+ (define (factorized-uri-code uri version)
+ (match (factorize-uri uri version)
+ ((? string? uri) uri)
+ ((factorized ...) `(string-append ,@factorized))))
+
(define (source->code source version)
(let ((uri (origin-uri source))
(method (origin-method source))
@@ -98,9 +101,14 @@ when evaluated."
(guix hg-download)
(guix svn-download)))
(procedure-name method)))
- (uri (string-append ,@(match (factorize-uri uri version)
- ((? string? uri) (list uri))
- (factorized factorized))))
+ (uri ,(if version
+ (match uri
+ ((? string? uri)
+ (factorized-uri-code uri version))
+ ((lst ...)
+ `(list
+ ,@(map (cut factorized-uri-code <> version) uri))))
+ uri))
,(if (equal? (content-hash-algorithm hash) 'sha256)
`(sha256 (base32 ,(bytevector->nix-base32-string
(content-hash-value hash))))
@@ -110,36 +118,62 @@ when evaluated."
;; FIXME: in order to be able to throw away the directory prefix,
;; we just assume that the patch files can be found with
;; "search-patches".
- ,@(if (null? patches) '()
- `((patches (search-patches ,@(map basename patches))))))))
+ ,@(cond ((null? patches)
+ '())
+ ((every string? patches)
+ `((patches (search-patches ,@(map basename patches)))))
+ (else
+ `((patches (list ,@(map (match-lambda
+ ((? string? file)
+ `(search-patch ,file))
+ ((? origin? origin)
+ (source->code origin #f)))
+ patches)))))))))
+
+ (define (variable-reference module name)
+ ;; FIXME: using '@ certainly isn't pretty, but it avoids having to import
+ ;; the individual package modules.
+ (list '@ module name))
+
+ (define (object->code obj quoted?)
+ (match obj
+ ((? package? package)
+ (let* ((module (package-module-name package))
+ (name (variable-name package module)))
+ (if quoted?
+ (list 'unquote (variable-reference module name))
+ (variable-reference module name))))
+ ((? origin? origin)
+ (let ((code (source->code origin #f)))
+ (if quoted?
+ (list 'unquote code)
+ code)))
+ ((lst ...)
+ (let ((lst (map (cut object->code <> #t) lst)))
+ (if quoted?
+ lst
+ (list 'quasiquote lst))))
+ (obj
+ obj)))
(define (inputs->code inputs)
(if (redundant-input-labels? inputs)
`(list ,@(map (match-lambda ;no need for input labels ("new style")
((_ package)
- (let ((module (package-module-name package)))
- `(@ ,module ,(variable-name package module))))
+ (let* ((module (package-module-name package))
+ (name (variable-name package module)))
+ (variable-reference module name)))
((_ package output)
- (let ((module (package-module-name package)))
+ (let* ((module (package-module-name package))
+ (name (variable-name package module)))
(list 'quasiquote
(list
(list 'unquote
- `(@ ,module
- ,(variable-name package module)))
+ (variable-reference module name))
output)))))
inputs))
(list 'quasiquote ;preserve input labels (deprecated)
- (map (match-lambda
- ((label pkg . out)
- (let ((mod (package-module-name pkg)))
- (cons* label
- ;; FIXME: using '@ certainly isn't pretty, but it
- ;; avoids having to import the individual package
- ;; modules.
- (list 'unquote
- (list '@ mod (variable-name pkg mod)))
- out))))
- inputs))))
+ (object->code inputs #t))))
(let ((name (package-name package))
(version (package-version package))
@@ -175,7 +209,8 @@ when evaluated."
'-build-system)))
,@(match arguments
(() '())
- (args `((arguments ,(list 'quasiquote args)))))
+ (_ `((arguments
+ ,(list 'quasiquote (object->code arguments #t))))))
,@(match outputs
(("out") '())
(outs `((outputs (list ,@outs)))))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index d5035b790b..2b33b3b8bc 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -128,27 +128,30 @@
missing-source-error?
(package missing-source-error-package))
-(define (latest-source-release pypi-package)
- "Return the latest source release for PYPI-PACKAGE."
- (let ((releases (assoc-ref (pypi-project-releases pypi-package)
- (project-info-version
- (pypi-project-info pypi-package)))))
+(define (latest-version project)
+ "Return the latest version of PROJECT, a <pypi-project> record."
+ (project-info-version (pypi-project-info project)))
+
+(define* (source-release pypi-package
+ #:optional (version (latest-version pypi-package)))
+ "Return the source release of VERSION for PYPI-PACKAGE, a <pypi-project>
+record, by default the latest version."
+ (let ((releases (or (assoc-ref (pypi-project-releases pypi-package) version)
+ '())))
(or (find (lambda (release)
(string=? "sdist" (distribution-package-type release)))
releases)
(raise (condition (&missing-source-error
(package pypi-package)))))))
-(define (latest-wheel-release pypi-package)
+(define* (wheel-release pypi-package
+ #:optional (version (latest-version 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-project-releases pypi-package)
- (project-info-version
- (pypi-project-info pypi-package)))))
- (or (find (lambda (release)
- (string=? "bdist_wheel" (distribution-package-type release)))
- releases)
- #f)))
+ (let ((releases (assoc-ref (pypi-project-releases pypi-package) version)))
+ (find (lambda (release)
+ (string=? "bdist_wheel" (distribution-package-type release)))
+ releases)))
(define (python->package-name name)
"Given the NAME of a package on PyPI, return a Guix-compliant name for the
@@ -477,18 +480,17 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
"Fetch the metadata for PACKAGE-NAME from pypi.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
(let* ((project (pypi-fetch package-name))
- (info (and project (pypi-project-info project))))
+ (info (and=> project pypi-project-info))
+ (version (or version (and=> project latest-version))))
(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~%")
- (project-info-name info)
- (project-info-version info)))))
- (make-pypi-sexp (project-info-name info)
- (project-info-version info)
- (and=> (latest-source-release project)
+ (project-info-name info) version))))
+ (make-pypi-sexp (project-info-name info) version
+ (and=> (source-release project version)
distribution-url)
- (and=> (latest-wheel-release project)
+ (and=> (wheel-release project version)
distribution-url)
(project-info-home-page info)
(project-info-summary info)
@@ -496,8 +498,9 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(string->license
(project-info-license info)))))))))
-(define (pypi-recursive-import package-name)
+(define* (pypi-recursive-import package-name #:optional version)
(recursive-import package-name
+ #:version version
#:repo->guix-package pypi->guix-package
#:guix-name python->package-name))
@@ -531,7 +534,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(let* ((info (pypi-project-info pypi-package))
(version (project-info-version info))
(url (distribution-url
- (latest-source-release pypi-package))))
+ (source-release pypi-package))))
(upstream-source
(urls (list url))
(input-changes
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index a180742ca3..dc89386ddb 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -152,6 +152,7 @@ of the string VERSION is replaced by the symbol 'version."
("CC0-1.0" 'license:cc0)
("CC-BY-2.0" 'license:cc-by2.0)
("CC-BY-3.0" 'license:cc-by3.0)
+ ("CC-BY-4.0" 'license:cc-by4.0)
("CC-BY-SA-2.0" 'license:cc-by-sa2.0)
("CC-BY-SA-3.0" 'license:cc-by-sa3.0)
("CC-BY-SA-4.0" 'license:cc-by-sa4.0)
@@ -163,6 +164,7 @@ of the string VERSION is replaced by the symbol 'version."
("EPL-1.0" 'license:epl1.0)
("MIT" 'license:expat)
("FTL" 'license:freetype)
+ ("Freetype" 'license:freetype)
("GFDL-1.1" 'license:fdl1.1+)
("GFDL-1.2" 'license:fdl1.2+)
("GFDL-1.3" 'license:fdl1.3+)
@@ -179,6 +181,7 @@ of the string VERSION is replaced by the symbol 'version."
("GPL-3.0-only" 'license:gpl3)
("GPL-3.0+" 'license:gpl3+)
("GPL-3.0-or-later" 'license:gpl3+)
+ ("HPND" 'license:hpnd)
("ISC" 'license:isc)
("IJG" 'license:ijg)
("Imlib2" 'license:imlib2)
diff --git a/guix/licenses.scm b/guix/licenses.scm
index c071aae4a9..82ca44f42e 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -308,6 +308,8 @@ at URI, which may be a file:// URI pointing the package's tree."
"https://directory.fsf.org/wiki/License:EUPL-1.2"
"https://www.gnu.org/licenses/license-list#EUPL-1.2"))
+;; Some people call it the MIT license. For clarification see:
+;; https://www.gnu.org/licenses/license-list.html#Expat
(define expat
(license "Expat"
"http://directory.fsf.org/wiki/License:Expat"
diff --git a/guix/packages.scm b/guix/packages.scm
index 083ee6d3b6..b3c5a00011 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -551,7 +551,7 @@ Texinfo. Otherwise, return the string."
(sanitize validate-texinfo)) ; one-line description
(description package-description
(sanitize validate-texinfo)) ; one or two paragraphs
- (license package-license) ; <license> instance or list
+ (license package-license) ; (list of) <license>
(home-page package-home-page)
(supported-systems package-supported-systems ; list of strings
(default %supported-systems))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 8176de4a5e..821f20e2f2 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -517,7 +517,7 @@ environment~%")))
(unless warned?
(match (vhash-assoc "PS1" actual)
(#f #f)
- (str
+ ((_ . str)
(when (and (getenv "PS1") (string=? str (getenv "PS1")))
(warning (G_ "'PS1' is the same in sub-shell~%"))
(display-hint (G_ "Consider setting a different prompt for
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index 3e4b038cc4..2934d4300a 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -27,8 +27,8 @@
#:use-module (guix import utils)
#:use-module (guix scripts import)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (guix-import-cran))
@@ -98,21 +98,24 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
(reverse opts))))
(parameterize ((%input-style (assoc-ref opts 'style)))
(match args
- ((package-name)
- (if (assoc-ref opts 'recursive)
- ;; Recursive import
- (with-error-handling
- (map package->definition
- (filter identity
- (cran-recursive-import package-name
- #:repo (or (assoc-ref opts 'repo) 'cran)))))
- ;; Single import
- (let ((sexp (cran->guix-package package-name
- #:repo (or (assoc-ref opts 'repo) 'cran))))
- (unless sexp
- (leave (G_ "failed to download description for package '~a'~%")
- package-name))
- sexp)))
+ ((spec)
+ (let ((name version (package-name->name+version spec)))
+ (if (assoc-ref opts 'recursive)
+ ;; Recursive import
+ (with-error-handling
+ (map package->definition
+ (filter identity
+ (cran-recursive-import name
+ #:version version
+ #:repo (or (assoc-ref opts 'repo) 'cran)))))
+ ;; Single import
+ (let ((sexp (cran->guix-package name
+ #:version version
+ #:repo (or (assoc-ref opts 'repo) 'cran))))
+ (unless sexp
+ (leave (G_ "failed to download description for package '~a'~%")
+ name))
+ sexp))))
(()
(leave (G_ "too few arguments~%")))
((many ...)
diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm
index 9170a0b359..a52cd95c93 100644
--- a/guix/scripts/import/pypi.scm
+++ b/guix/scripts/import/pypi.scm
@@ -27,6 +27,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (guix-import-pypi))
@@ -83,21 +84,22 @@ Import and convert the PyPI package for PACKAGE-NAME.\n"))
(_ #f))
(reverse opts))))
(match args
- ((package-name)
- (if (assoc-ref opts 'recursive)
- ;; Recursive import
- (map (match-lambda
- ((and ('package ('name name) . rest) pkg)
- `(define-public ,(string->symbol name)
- ,pkg))
- (_ #f))
- (pypi-recursive-import package-name))
- ;; Single import
- (let ((sexp (pypi->guix-package package-name)))
- (unless sexp
- (leave (G_ "failed to download meta-data for package '~a'~%")
- package-name))
- sexp)))
+ ((spec)
+ (let ((name version (package-name->name+version spec)))
+ (if (assoc-ref opts 'recursive)
+ ;; Recursive import
+ (map (match-lambda
+ ((and ('package ('name name) . rest) pkg)
+ `(define-public ,(string->symbol name)
+ ,pkg))
+ (_ #f))
+ (pypi-recursive-import name version))
+ ;; Single import
+ (let ((sexp (pypi->guix-package name #:version version)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for package '~a'~%")
+ name))
+ sexp))))
(()
(leave (G_ "too few arguments~%")))
((many ...)
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index cd9660174c..370df4a74c 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
-;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,12 +22,13 @@
(define-module (guix store deduplication)
#:use-module (gcrypt hash)
- #:use-module (guix build utils)
+ #:use-module ((guix build utils) #:hide (dump-port))
#:use-module (guix build syscalls)
#:use-module (guix base32)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
@@ -37,6 +38,31 @@
dump-file/deduplicate
copy-file/deduplicate))
+;; TODO: Remove once 'dump-port' in (guix build utils) has an optional 'len'
+;; parameter.
+(define* (dump-port in out
+ #:optional len
+ #:key (buffer-size 16384))
+ "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it
+to OUT, using chunks of BUFFER-SIZE bytes."
+ (define buffer
+ (make-bytevector buffer-size))
+
+ (let loop ((total 0)
+ (bytes (get-bytevector-n! in buffer 0
+ (if len
+ (min len buffer-size)
+ buffer-size))))
+ (or (eof-object? bytes)
+ (and len (= total len))
+ (let ((total (+ total bytes)))
+ (put-bytevector out buffer 0 bytes)
+ (loop total
+ (get-bytevector-n! in buffer 0
+ (if len
+ (min (- len total) buffer-size)
+ buffer-size)))))))
+
(define (nar-sha256 file)
"Gives the sha256 hash of a file and the size of the file in nar form."
(let-values (((port get-hash) (open-sha256-port)))
@@ -127,11 +153,27 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
(unless (= EMLINK (system-error-errno args))
(apply throw args)))))))
+(define %deduplication-minimum-size
+ ;; Size below which files are not deduplicated. This avoids adding too many
+ ;; entries to '.links', which would slow down 'removeUnusedLinks' while
+ ;; saving little space. Keep in sync with optimize-store.cc.
+ 8192)
+
(define* (deduplicate path hash #:key (store (%store-directory)))
"Check if a store item with sha256 hash HASH already exists. If so,
replace PATH with a hardlink to the already-existing one. If not, register
PATH so that future duplicates can hardlink to it. PATH is assumed to be
under STORE."
+ ;; Lightweight promises.
+ (define-syntax-rule (delay exp)
+ (let ((value #f))
+ (lambda ()
+ (unless value
+ (set! value exp))
+ value)))
+ (define-syntax-rule (force promise)
+ (promise))
+
(define links-directory
(string-append store "/.links"))
@@ -144,13 +186,18 @@ under STORE."
((file . properties)
(unless (member file '("." ".."))
(let* ((file (string-append path "/" file))
+ (st (delay (lstat file)))
(type (match (assoc-ref properties 'type)
((or 'unknown #f)
- (stat:type (lstat file)))
+ (stat:type (force st)))
(type type))))
- (loop file type
- (and (not (eq? 'directory type))
- (nar-sha256 file)))))))
+ (when (or (eq? 'directory type)
+ (and (eq? 'regular type)
+ (>= (stat:size (force st))
+ %deduplication-minimum-size)))
+ (loop file type
+ (and (not (eq? 'directory type))
+ (nar-sha256 file))))))))
(scandir* path))
(let ((link-file (string-append links-directory "/"
(bytevector->nix-base32-string hash))))
@@ -222,9 +269,9 @@ OUTPUT as it goes."
This procedure is suitable as a #:dump-file argument to 'restore-file'. When
used that way, it deduplicates files on the fly as they are restored, thereby
-removing the need to a deduplication pass that would re-read all the files
+removing the need for a deduplication pass that would re-read all the files
down the road."
- (define hash
+ (define (dump-and-compute-hash)
(call-with-output-file file
(lambda (output)
(let-values (((hash-port get-hash)
@@ -236,7 +283,11 @@ down the road."
(close-port hash-port)
(get-hash)))))
- (deduplicate file hash #:store store))
+ (if (>= size %deduplication-minimum-size)
+ (deduplicate file (dump-and-compute-hash) #:store store)
+ (call-with-output-file file
+ (lambda (output)
+ (dump-port input output size)))))
(define* (copy-file/deduplicate source target
#:key (store (%store-directory)))
diff --git a/guix/tests.scm b/guix/tests.scm
index 063b20183d..4cd1ad6cf9 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -189,18 +189,22 @@ too expensive to build entirely in the test store."
(loop (1+ i)))
bv))))
-(define (file=? a b)
- "Return true if files A and B have the same type and same content."
- (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
- (case (stat:type (lstat a))
- ((regular)
- (equal?
- (call-with-input-file a get-bytevector-all)
- (call-with-input-file b get-bytevector-all)))
- ((symlink)
- (string=? (readlink a) (readlink b)))
- (else
- (error "what?" (lstat a))))))
+(define* (file=? a b #:optional (stat lstat))
+ "Return true if files A and B have the same type and same content. Call
+STAT to obtain file metadata."
+ (let ((sta (stat a)) (stb (stat b)))
+ (and (eq? (stat:type sta) (stat:type stb))
+ (case (stat:type sta)
+ ((regular)
+ (or (and (= (stat:ino sta) (stat:ino stb))
+ (= (stat:dev sta) (stat:dev stb)))
+ (equal?
+ (call-with-input-file a get-bytevector-all)
+ (call-with-input-file b get-bytevector-all))))
+ ((symlink)
+ (string=? (readlink a) (readlink b)))
+ (else
+ (error "what?" (stat a)))))))
(define (canonical-file? file)
"Return #t if FILE is in the store, is read-only, and its mtime is 1."