summaryrefslogtreecommitdiff
path: root/guix/import
diff options
context:
space:
mode:
Diffstat (limited to 'guix/import')
-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
4 files changed, 147 insertions, 79 deletions
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)
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-10 07:15:38 +0000