01/35: import/cran: Accept optional alternative download procedure.

[guix-commits]

rekado pushed a commit to branch master
in repository guix.

commit b94047cf810c70e6a596cea539e50d487f5c044e
Author: Ricardo Wurmus <rekado@elephly.net>
AuthorDate: Wed Jan 17 22:59:11 2024 +0100

    import/cran: Accept optional alternative download procedure.
    
    This is useful for cached mass imports.
    
    * guix/import/cran.scm (fetch-description-from-tarball): Accept optional
    download keyword.
    (fetch-description): Accept optional replacement-download argument.
    
    Change-Id: Ic917074656ac34a24c8e7eea3d3e0528fc5180b3
---
 guix/import/cran.scm | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 6eddcbfb7b..b3bd6f89ce 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -270,7 +270,7 @@ bioconductor package NAME, or #F if the package is unknown."
             ;; of the URLs is the /Archive CRAN URL.
             (any (cut download-to-store store <>) urls)))))))))
 
-(define (fetch-description-from-tarball url)
+(define* (fetch-description-from-tarball url #:key (download download))
   "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and
 return the resulting alist."
   (match (download url)
@@ -288,7 +288,7 @@ return the resulting alist."
                 (call-with-input-file (string-append dir "/DESCRIPTION")
                   read-string)))))))))
 
-(define* (fetch-description repository name #:optional version)
+(define* (fetch-description repository name #:optional version 
replacement-download)
   "Return an alist of the contents of the DESCRIPTION file for the R package
 NAME at VERSION in the given REPOSITORY, or #f in case of failure.  NAME is
 case-sensitive."
@@ -310,7 +310,9 @@ from ~a: ~a (~a)~%")
                              (string-append 
"mirror://cran/src/contrib/Archive/"
                                             name "/"
                                             name "_" version ".tar.gz"))))
-             (fetch-description-from-tarball urls))
+             (fetch-description-from-tarball
+              urls #:download (or replacement-download
+                                  download)))
            (let* ((url    (string-append %cran-url name "/DESCRIPTION"))
                   (port   (http-fetch url))
                   (result (description->alist (read-string port))))
@@ -327,7 +329,9 @@ from ~a: ~a (~a)~%")
                 ;; TODO: Honor VERSION.
                 (version (latest-bioconductor-package-version name type))
                 (url     (car (bioconductor-uri name version type)))
-                (meta    (fetch-description-from-tarball url)))
+                (meta    (fetch-description-from-tarball
+                          url #:download (or replacement-download
+                                             download))))
        (if (boolean? type)
            meta
            (cons `(bioconductor-type . ,type) meta))))