diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
commit | d1f3b333e6176a7879ab3742bbebb2a99f61a528 (patch) | |
tree | 8bd82ce68bd2534a48bf13c7256997f82dd1b3f4 /guix/import/cran.scm | |
parent | e01d384efcdaf564bbb221e43b81e087c8e2af06 (diff) | |
parent | 861907f01efb1cae7f260e8cb7b991d5034a486a (diff) | |
download | guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar.gz |
Merge branch 'master' into staging
Diffstat (limited to 'guix/import/cran.scm')
-rw-r--r-- | guix/import/cran.scm | 296 |
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 |