diff options
| -rw-r--r-- | guix/import/cran.scm | 96 |
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)) |