[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: import/cran: Support importing from Mercurial repositories.
|
From: |
guix-commits |
|
Subject: |
03/03: import/cran: Support importing from Mercurial repositories. |
|
Date: |
Wed, 25 Mar 2020 04:40:15 -0400 (EDT) |
rekado pushed a commit to branch master
in repository guix.
commit b005c240bb5e436ffe9d55c2dd75c9af85aa0fdd
Author: Ricardo Wurmus <address@hidden>
AuthorDate: Wed Mar 25 09:36:58 2020 +0100
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.
---
guix/import/cran.scm | 96 +++++++++++++++++++++++++++++++++++++++++-----------
1 file changed, 77 insertions(+), 19 deletions(-)
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index bb8226f..9929f3c 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))