import/cran: Support importing from Mercurial repositories.

* guix/import/cran.scm (download): Accept keyword #:method; add case for hg
method.
(fetch-description): Handle hg repository.
(description->package): Add cases for hg repositories and update call of
DOWNLOAD procedure.
(cran->guix-package): Retry importing from Bioconductor when hg import failed.

1 files changed, 77 insertions, 19 deletions

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index bb8226f714..9929f3cfae 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -21,6 +21,7 @@
 (define-module (guix import cran)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 popen)
   #:use-module ((ice-9 rdelim) #:select (read-string read-line))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
@@ -37,7 +38,10 @@
   #: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 build utils)
+                #:select (find-files
+                          delete-file-recursively
+                          with-directory-excursion))
   #:use-module (guix utils)
   #:use-module (guix git)
   #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
@@ -191,11 +195,26 @@ bioconductor package NAME, or #F if the package is unknown."
 ;; Little helper to download URLs only once.
 (define download
   (memoize
-   (lambda* (url #:optional git)
+   (lambda* (url #:key method)
      (with-store store
-       (if git
-           (latest-repository-commit store url)
-           (download-to-store store url))))))
+       (cond
+        ((eq? method 'git)
+         (latest-repository-commit store url))
+        ((eq? method 'hg)
+         (call-with-temporary-directory
+          (lambda (dir)
+            (unless (zero? (system* "hg" "clone" url dir))
+              (leave (G_ "~A: hg download failed~%") url))
+            (with-directory-excursion dir
+              (let* ((port (open-pipe* OPEN_READ "hg" "id" "--id"))
+                     (changeset (string-trim-right (read-string port))))
+                (close-pipe port)
+                (for-each delete-file-recursively
+                          (find-files dir "^\\.hg$" #:directories? #t))
+                (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)
   "Return an alist of the contents of the DESCRIPTION file for the R package
@@ -244,13 +263,25 @@ from ~s: ~a (~s)~%"
      (and (string-prefix? "http" name)
           ;; Download the git repository at "NAME"
           (call-with-values
-              (lambda () (download name #t))
+              (lambda () (download name #:method 'git))
             (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)))))))
+    ((hg)
+     (and (string-prefix? "http" name)
+          ;; Download the mercurial repository at "NAME"
+          (call-with-values
+              (lambda () (download name #:method 'hg))
+            (lambda (dir changeset)
+              (and=> (description->alist (with-input-from-file
+                                             (string-append dir "/DESCRIPTION") read-string))
+                     (lambda (meta)
+                       (cons* `(hg . ,name)
+                              `(hg-changeset . ,changeset)
                               meta)))))))))
 
 (define (listify meta field)
@@ -404,11 +435,13 @@ 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)
-                       ((git)          #f)))
+                       ((git)          #f)
+                       ((hg)           #f)))
          (uri-helper (case repository
                        ((cran)         cran-uri)
                        ((bioconductor) bioconductor-uri)
-                       ((git)          #f)))
+                       ((git)          #f)
+                       ((hg)           #f)))
          (name       (assoc-ref meta "Package"))
          (synopsis   (assoc-ref meta "Title"))
          (version    (assoc-ref meta "Version"))
@@ -416,11 +449,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
          ;; Some packages have multiple home pages.  Some have none.
          (home-page  (case repository
                        ((git) (assoc-ref meta 'git))
+                       ((hg)  (assoc-ref meta 'hg))
                        (else (match (listify meta "URL")
                                ((url rest ...) url)
                                (_ (string-append base-url name))))))
          (source-url (case repository
                        ((git) (assoc-ref meta 'git))
+                       ((hg)  (assoc-ref meta 'hg))
                        (else
                         (match (apply uri-helper name version
                                       (case repository
@@ -431,9 +466,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
                           ((? string? url) url)
                           (_ #f)))))
          (git?       (assoc-ref meta 'git))
-         (source     (download source-url git?))
+         (hg?        (assoc-ref meta 'hg))
+         (source     (download source-url #:method (cond
+                                                    (git? 'git)
+                                                    (hg? 'hg)
+                                                    (else #f))))
          (sysdepends (append
-                      (if (needs-zlib? source (not git?)) '("zlib") '())
+                      (if (needs-zlib? source (not (or git? hg?))) '("zlib") '())
                       (filter (lambda (name)
                                 (not (member name invalid-packages)))
                               (map string-downcase (listify meta "SystemRequirements")))))
@@ -451,33 +490,45 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
               (version ,(case repository
                           ((git)
                            `(git-version ,version revision commit))
+                          ((hg)
+                           `(string-append ,version "-" revision "." changeset))
                           (else version)))
               (source (origin
-                        (method ,(if git?
-                                     'git-fetch
-                                     'url-fetch))
+                        (method ,(cond
+                                  (git? 'git-fetch)
+                                  (hg?  'hg-fetch)
+                                  (else 'url-fetch)))
                         (uri ,(case repository
                                 ((git)
                                  `(git-reference
                                    (url ,(assoc-ref meta 'git))
                                    (commit commit)))
+                                ((hg)
+                                 `(hg-reference
+                                   (url ,(assoc-ref meta 'hg))
+                                   (changeset changeset)))
                                 (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)))
-                              '())
+                        ,@(cond
+                           (git?
+                            '((file-name (git-file-name name version))))
+                           (hg?
+                            '((file-name (string-append name "-" version "-checkout"))))
+                           (else '()))
                         (sha256
                          (base32
                           ,(bytevector->nix-base32-string
                             (case repository
                               ((git)
                                (file-hash source (negate vcs-file?) #t))
+                              ((hg)
+                               (file-hash source (negate vcs-file?) #t))
                               (else (file-sha256 source))))))))
-              ,@(if (not (and git?
+              ,@(if (not (and git? hg?
                               (equal? (string-append "r-" name)
                                       (cran-guix-name name))))
                     `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
@@ -486,9 +537,9 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
               ,@(maybe-inputs sysdepends)
               ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
               ,@(maybe-inputs
-                 `(,@(if (needs-fortran? source (not git?))
+                 `(,@(if (needs-fortran? source (not (or git? hg?)))
                          '("gfortran") '())
-                   ,@(if (needs-pkg-config? source (not git?))
+                   ,@(if (needs-pkg-config? source (not (or git? hg?)))
                          '("pkg-config") '())
                    ,@(if (needs-knitr? meta)
                          '("r-knitr") '()))
@@ -506,6 +557,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
         `(let ((commit ,(assoc-ref meta 'git-commit))
                (revision "1"))
            ,package))
+       ((hg)
+        `(let ((changeset ,(assoc-ref meta 'hg-changeset))
+               (revision "1"))
+           ,package))
        (else package))
      propagate)))
 
@@ -521,6 +576,9 @@ s-expression corresponding to that package, or #f on failure."
              ((git)
               ;; Retry import from Bioconductor
               (cran->guix-package package-name 'bioconductor))
+             ((hg)
+              ;; Retry import from Bioconductor
+              (cran->guix-package package-name 'bioconductor))
              ((bioconductor)
               ;; Retry import from CRAN
               (cran->guix-package package-name 'cran))