diff options
author | Marius Bakke <mbakke@fastmail.com> | 2017-11-19 15:01:00 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2017-11-19 15:01:00 +0100 |
commit | 2dd12924cf4a30a96262b6d392fcde58c9f10d4b (patch) | |
tree | 3f74f5426ff214a02b8f6652f6516979657a7f98 /guix/import | |
parent | 259b4f34ba2eaefeafdb7c9f9eb56ee77f16010c (diff) | |
parent | a93447b89a5b132221072e729d13a3f17391b8c2 (diff) |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/import')
-rw-r--r-- | guix/import/cran.scm | 91 | ||||
-rw-r--r-- | guix/import/utils.scm | 28 |
2 files changed, 93 insertions, 26 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 9b08ebfb63..ec2b7e6029 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -128,30 +128,72 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.5. Bioconductor packages should be +;; The latest Bioconductor release is 3.6. Bioconductor packages should be ;; updated together. -(define (bioconductor-mirror-url name) - (string-append "https://raw.githubusercontent.com/Bioconductor-mirror/" - name "/release-3.5")) +(define %bioconductor-version "3.6") -(define (fetch-description repository name) - "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 -case-sensitive." - ;; This API always returns the latest release of the module. - (let ((url (string-append (case repository - ((cran) (string-append %cran-url name)) - ((bioconductor) (bioconductor-mirror-url name))) - "/DESCRIPTION"))) +(define %bioconductor-packages-list-url + (string-append "https://bioconductor.org/packages/" + %bioconductor-version "/bioc/src/contrib/PACKAGES")) + +(define (bioconductor-packages-list) + "Return the latest version of package NAME for the current bioconductor +release." + (let ((url (string->uri %bioconductor-packages-list-url))) (guard (c ((http-get-error? c) (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" + "error: failed to retrieve list of packages from ~s: ~a (~s)~%" (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) #f)) - (description->alist (read-string (http-fetch url)))))) + ;; Split the big list on empty lines, then turn each chunk into an + ;; alist of attributes. + (map (lambda (chunk) + (description->alist (string-join chunk "\n"))) + (chunk-lines (read-lines (http-fetch/cached url))))))) + +(define (latest-bioconductor-package-version name) + "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)) + (cut assoc-ref <> "Version"))) + +(define (fetch-description repository name) + "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 +case-sensitive." + (case repository + ((cran) + (let ((url (string-append %cran-url name "/DESCRIPTION"))) + (guard (c ((http-get-error? c) + (format (current-error-port) + "error: failed to retrieve package information \ +from ~s: ~a (~s)~%" + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + #f)) + (description->alist (read-string (http-fetch url)))))) + ((bioconductor) + ;; 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. + (let* ((version (latest-bioconductor-package-version name)) + (url (car (bioconductor-uri name version))) + (tarball (with-store store (download-to-store store 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")) + (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)))))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -419,16 +461,15 @@ dependencies." (define upstream-name (package->upstream-name package)) - (define meta - (fetch-description 'bioconductor upstream-name)) + (define version + (latest-bioconductor-package-version upstream-name)) - (and meta - (let ((version (assoc-ref meta "Version"))) - ;; Bioconductor does not provide signatures. - (upstream-source - (package (package-name package)) - (version version) - (urls (list (bioconductor-uri upstream-name version))))))) + (and version + ;; Bioconductor does not provide signatures. + (upstream-source + (package (package-name package)) + (version version) + (urls (bioconductor-uri upstream-name version))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 1e2f0c809d..d4cef6b503 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -34,6 +34,8 @@ #:use-module (guix download) #:use-module (gnu packages) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -56,7 +58,10 @@ snake-case beautify-description - alist->package)) + alist->package + + read-lines + chunk-lines)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -329,3 +334,24 @@ the expected fields of an <origin> object." (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) (spdx-string->license l)) (license:fsdg-compatible l)))))) + +(define* (read-lines #:optional (port (current-input-port))) + "Read lines from PORT and return them as a list." + (let loop ((line (read-line port)) + (lines '())) + (if (eof-object? line) + (reverse lines) + (loop (read-line port) + (cons line lines))))) + +(define* (chunk-lines lines #:optional (pred string-null?)) + "Return a list of chunks, each of which is a list of lines. The chunks are +separated by PRED." + (let loop ((rest lines) + (parts '())) + (receive (before after) + (break pred rest) + (let ((res (cons before parts))) + (if (null? after) + (reverse res) + (loop (cdr after) res)))))) |