Merge branch 'master' into core-updates

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