summaryrefslogtreecommitdiff
path: root/guix/import/cran.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/import/cran.scm')
-rw-r--r--guix/import/cran.scm296
1 files changed, 217 insertions, 79 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 3240094444..e47aff2b12 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -24,6 +24,7 @@
#:use-module ((ice-9 rdelim) #:select (read-string read-line))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (ice-9 receive)
@@ -32,11 +33,13 @@
#:use-module (guix http-client)
#:use-module (gcrypt hash)
#:use-module (guix store)
+ #:use-module ((guix serialization) #:select (write-file))
#:use-module (guix base32)
#:use-module ((guix download) #:select (download-to-store))
#:use-module (guix import utils)
#:use-module ((guix build utils) #:select (find-files))
#:use-module (guix utils)
+ #:use-module (guix git)
#:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
#:use-module (guix upstream)
#:use-module (guix packages)
@@ -46,6 +49,7 @@
cran-recursive-import
%cran-updater
%bioconductor-updater
+ %bioconductor-version
cran-package?
bioconductor-package?
@@ -132,14 +136,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,19 +162,33 @@ 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")))
+;; XXX taken from (guix scripts hash)
+(define (vcs-file? file stat)
+ (case (stat:type stat)
+ ((directory)
+ (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+ ((regular)
+ ;; Git sub-modules have a '.git' file that is a regular text file.
+ (string=? (basename file) ".git"))
+ (else
+ #f)))
+
;; Little helper to download URLs only once.
(define download
(memoize
- (lambda (url)
- (with-store store (download-to-store store url)))))
+ (lambda* (url #:optional git)
+ (with-store store
+ (if git
+ (latest-repository-commit store url)
+ (download-to-store store url))))))
(define (fetch-description repository name)
"Return an alist of the contents of the DESCRIPTION file for the R package
@@ -187,8 +210,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 +225,23 @@ 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))))))))))
+ ((git)
+ (and (string-prefix? "http" name)
+ ;; Download the git repository at "NAME"
+ (call-with-values
+ (lambda () (download name #t))
+ (lambda (dir commit)
+ (and=> (description->alist (with-input-from-file
+ (string-append dir "/DESCRIPTION") read-string))
+ (lambda (meta)
+ (cons* `(git . ,name)
+ `(git-commit . ,commit)
+ meta)))))))))
(define (listify meta field)
"Look up FIELD in the alist META. If FIELD contains a comma-separated
@@ -244,7 +286,7 @@ empty list when the FIELD cannot be found."
(define cran-guix-name (cut guix-name "r-" <>))
-(define (needs-fortran? tarball)
+(define (tarball-needs-fortran? tarball)
"Check if the TARBALL contains Fortran source files."
(define (check pattern)
(parameterize ((current-error-port (%make-void-port "rw+"))
@@ -254,65 +296,127 @@ empty list when the FIELD cannot be found."
(check "*.f95")
(check "*.f")))
+(define (directory-needs-fortran? dir)
+ "Check if the directory DIR contains Fortran source files."
+ (match (find-files dir "\\.f(90|95)?")
+ (() #f)
+ (_ #t)))
+
+(define (needs-fortran? thing tarball?)
+ "Check if the THING contains Fortran source files."
+ (if tarball?
+ (tarball-needs-fortran? thing)
+ (directory-needs-fortran? thing)))
+
+(define (files-match-pattern? directory regexp . file-patterns)
+ "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match
+the given REGEXP."
+ (let ((pattern (make-regexp regexp)))
+ (any (lambda (file)
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ()
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line) #f)
+ ((regexp-exec pattern line) #t)
+ (else (loop))))))))
+ (apply find-files directory file-patterns))))
+
(define (tarball-files-match-pattern? tarball regexp . file-patterns)
"Return #T if any of the files represented by FILE-PATTERNS in the TARBALL
match the given REGEXP."
(call-with-temporary-directory
(lambda (dir)
- (let ((pattern (make-regexp regexp)))
- (parameterize ((current-error-port (%make-void-port "rw+")))
- (apply system* "tar"
- "xf" tarball "-C" dir
- `("--wildcards" ,@file-patterns)))
- (any (lambda (file)
- (call-with-input-file file
- (lambda (port)
- (let loop ()
- (let ((line (read-line port)))
- (cond
- ((eof-object? line) #f)
- ((regexp-exec pattern line) #t)
- (else (loop))))))))
- (find-files dir))))))
-
-(define (needs-zlib? tarball)
+ (parameterize ((current-error-port (%make-void-port "rw+")))
+ (apply system* "tar"
+ "xf" tarball "-C" dir
+ `("--wildcards" ,@file-patterns)))
+ (files-match-pattern? dir regexp))))
+
+(define (directory-needs-zlib? dir)
+ "Return #T if any of the Makevars files in the src directory DIR contain a
+zlib linker flag."
+ (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)"))
+
+(define (tarball-needs-zlib? tarball)
"Return #T if any of the Makevars files in the src directory of the TARBALL
contain a zlib linker flag."
(tarball-files-match-pattern?
tarball "-lz"
"*/src/Makevars*" "*/src/configure*" "*/configure*"))
-(define (needs-pkg-config? tarball)
+(define (needs-zlib? thing tarball?)
+ "Check if the THING contains files indicating a dependency on zlib."
+ (if tarball?
+ (tarball-needs-zlib? thing)
+ (directory-needs-zlib? thing)))
+
+(define (directory-needs-pkg-config? dir)
+ "Return #T if any of the Makevars files in the src directory DIR reference
+the pkg-config tool."
+ (files-match-pattern? dir "pkg-config"
+ "(Makevars.*|configure.*)"))
+
+(define (tarball-needs-pkg-config? tarball)
"Return #T if any of the Makevars files in the src directory of the TARBALL
reference the pkg-config tool."
(tarball-files-match-pattern?
tarball "pkg-config"
"*/src/Makevars*" "*/src/configure*" "*/configure*"))
+(define (needs-pkg-config? thing tarball?)
+ "Check if the THING contains files indicating a dependency on pkg-config."
+ (if tarball?
+ (tarball-needs-pkg-config? thing)
+ (directory-needs-pkg-config? thing)))
+
+;; XXX adapted from (guix scripts hash)
+(define (file-hash file select? recursive?)
+ ;; Compute the hash of FILE.
+ (if recursive?
+ (let-values (((port get-hash) (open-sha256-port)))
+ (write-file file port #:select? select?)
+ (force-output port)
+ (get-hash))
+ (call-with-input-file file port-sha256)))
+
(define (description->package repository meta)
"Return the `package' s-expression for an R package published on REPOSITORY
from the alist META, which was derived from the R package's DESCRIPTION file."
(let* ((base-url (case repository
((cran) %cran-url)
- ((bioconductor) %bioconductor-url)))
+ ((bioconductor) %bioconductor-url)
+ ((git) #f)))
(uri-helper (case repository
((cran) cran-uri)
- ((bioconductor) bioconductor-uri)))
+ ((bioconductor) bioconductor-uri)
+ ((git) #f)))
(name (assoc-ref meta "Package"))
(synopsis (assoc-ref meta "Title"))
(version (assoc-ref meta "Version"))
(license (string->license (assoc-ref meta "License")))
;; Some packages have multiple home pages. Some have none.
- (home-page (match (listify meta "URL")
- ((url rest ...) url)
- (_ (string-append base-url name))))
- (source-url (match (uri-helper name version)
- ((url rest ...) url)
- ((? string? url) url)
- (_ #f)))
- (tarball (download source-url))
+ (home-page (case repository
+ ((git) (assoc-ref meta 'git))
+ (else (match (listify meta "URL")
+ ((url rest ...) url)
+ (_ (string-append base-url name))))))
+ (source-url (case repository
+ ((git) (assoc-ref meta 'git))
+ (else
+ (match (apply uri-helper name version
+ (case repository
+ ((bioconductor)
+ (list (assoc-ref meta 'bioconductor-type)))
+ (else '())))
+ ((url rest ...) url)
+ ((? string? url) url)
+ (_ #f)))))
+ (git? (assoc-ref meta 'git))
+ (source (download source-url git?))
(sysdepends (append
- (if (needs-zlib? tarball) '("zlib") '())
+ (if (needs-zlib? source (not git?)) '("zlib") '())
(filter (lambda (name)
(not (member name invalid-packages)))
(map string-downcase (listify meta "SystemRequirements")))))
@@ -323,37 +427,67 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(listify meta "Imports")
(listify meta "LinkingTo")
(delete "R"
- (listify meta "Depends"))))))
+ (listify meta "Depends")))))
+ (package
+ `(package
+ (name ,(cran-guix-name name))
+ (version ,(case repository
+ ((git)
+ `(git-version ,version revision commit))
+ (else version)))
+ (source (origin
+ (method ,(if git?
+ 'git-fetch
+ 'url-fetch))
+ (uri ,(case repository
+ ((git)
+ `(git-reference
+ (url ,(assoc-ref meta 'git))
+ (commit commit)))
+ (else
+ `(,(procedure-name uri-helper) ,name version
+ ,@(or (and=> (assoc-ref meta 'bioconductor-type)
+ (lambda (type)
+ (list (list 'quote type))))
+ '())))))
+ ,@(if git?
+ '((file-name (git-file-name name version)))
+ '())
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string
+ (case repository
+ ((git)
+ (file-hash source (negate vcs-file?) #t))
+ (else (file-sha256 source))))))))
+ ,@(if (not (and git?
+ (equal? (string-append "r-" name)
+ (cran-guix-name name))))
+ `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
+ '())
+ (build-system r-build-system)
+ ,@(maybe-inputs sysdepends)
+ ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
+ ,@(maybe-inputs
+ `(,@(if (needs-fortran? source (not git?))
+ '("gfortran") '())
+ ,@(if (needs-pkg-config? source (not git?))
+ '("pkg-config") '()))
+ 'native-inputs)
+ (home-page ,(if (string-null? home-page)
+ (string-append base-url name)
+ home-page))
+ (synopsis ,synopsis)
+ (description ,(beautify-description (or (assoc-ref meta "Description")
+ "")))
+ (license ,license))))
(values
- `(package
- (name ,(cran-guix-name name))
- (version ,version)
- (source (origin
- (method url-fetch)
- (uri (,(procedure-name uri-helper) ,name version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string (file-sha256 tarball))))))
- ,@(if (not (equal? (string-append "r-" name)
- (cran-guix-name name)))
- `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
- '())
- (build-system r-build-system)
- ,@(maybe-inputs sysdepends)
- ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
- ,@(maybe-inputs
- `(,@(if (needs-fortran? tarball)
- '("gfortran") '())
- ,@(if (needs-pkg-config? tarball)
- '("pkg-config") '()))
- 'native-inputs)
- (home-page ,(if (string-null? home-page)
- (string-append base-url name)
- home-page))
- (synopsis ,synopsis)
- (description ,(beautify-description (or (assoc-ref meta "Description")
- "")))
- (license ,license))
+ (case repository
+ ((git)
+ `(let ((commit ,(assoc-ref meta 'git-commit))
+ (revision "1"))
+ ,package))
+ (else package))
propagate)))
(define cran->guix-package
@@ -362,12 +496,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
"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)))
- (if (and (not description)
- (eq? repo 'bioconductor))
- ;; Retry import from CRAN
- (cran->guix-package package-name 'cran)
- (and description
- (description->package repo description)))))))
+ (if description
+ (description->package repo description)
+ (case repo
+ ((git)
+ ;; Retry import from Bioconductor
+ (cran->guix-package package-name 'bioconductor))
+ ((bioconductor)
+ ;; Retry import from CRAN
+ (cran->guix-package package-name 'cran))
+ (else #f)))))))
(define* (cran-recursive-import package-name #:optional (repo 'cran))
(recursive-import package-name repo