futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

import/cran: Support importing from Mercurial repositories.

Browse Source 
* 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 2020-03-25 09:36:58 +01:00
parent 2fcd2e1a5f
commit b005c240bb
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
1 changed files with 77 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
guix/import/cran.scm
View File

@ -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))