futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

import: cran: Allow imports of a specific version.

Browse Source 
* guix/import/cran.scm (download): Handle the case where URL is a list.
(fetch-description-from-tarball): New procedure.
(fetch-description): Add #:version parameter.  Honor it when REPOSITORY
is 'cran.  Use 'fetch-description-from-tarball' when REPOSITORY is
'bioconductor.
(description->package): SOURCE-URL may now be a list.
(cran->guix-package): Pass VERSION to 'fetch-description'.
(cran-recursive-import): Add #:version parameter.
* guix/scripts/import/cran.scm (guix-import-cran): Expect a spec rather
than a mere package name.
* doc/guix.texi (Invoking guix import): Document it.
This commit is contained in:
Ludovic Courtès 2021-10-29 21:26:16 +02:00
parent b20cd80ff1
commit 450e1dd52e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 83 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
doc/guix.texi
View File

@ -11833,6 +11833,12 @@ The command command below imports metadata for the Cairo R package:
guix import cran Cairo
@end example
You can also ask for a specific version:
@example
guix import cran rasterVis@@0.50.3
@end example
When @option{--recursive} is added, the importer will traverse the
dependency graph of the given upstream package recursively and generate
package expressions for all those packages that are not yet in Guix.

89
guix/import/cran.scm
View File

@ -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)))))))
(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 repository name)
(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))

35
guix/scripts/import/cran.scm
View File

@ -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 ...)