mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 22:08:16 -05:00
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.
This commit is contained in:
Ricardo Wurmus
parent
2fcd2e1a5f
commit
b005c240bb
1 changed files with 77 additions and 19 deletions
|
|
@ -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 @@ (define-module (guix import cran)
|
|||
#: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 @@ (define (vcs-file? file stat)
|
|||
;; 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 @@ (define (fetch-description repository name)
|
|||
(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 @@ (define (description->package repository meta)
|
|||
(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 @@ (define (description->package repository meta)
|
|||
;; 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 @@ (define (description->package repository meta)
|
|||
((? 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 @@ (define (description->package repository meta)
|
|||
(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 @@ (define (description->package repository meta)
|
|||
,@(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 @@ (define (description->package repository meta)
|
|||
`(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 @@ (define cran->guix-package
|
|||
((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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue