02/09: import: cran: Allow imports of a specific version.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 450e1dd52e0a34bb00fcb655956e40d69d50a331
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Oct 29 21:26:16 2021 +0200

    import: cran: Allow imports of a specific version.
    
    * 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.
---
 doc/guix.texi                |  6 +++
 guix/import/cran.scm         | 91 ++++++++++++++++++++++++++++----------------
 guix/scripts/import/cran.scm | 35 +++++++++--------
 3 files changed, 84 insertions(+), 48 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index c748a57..29a6665 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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.
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 07a5656..7478866 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -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)))))))
-
-(define (fetch-description repository name)
+        (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-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))
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index 3e4b038..2934d43 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -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 ...)