diff options
author | Marius Bakke <mbakke@fastmail.com> | 2020-03-27 00:12:15 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2020-03-27 00:12:15 +0100 |
commit | 18af6870370226b4d502d7372844e7f2aded5887 (patch) | |
tree | 749d93209bd0cb9710ccaae2207df670f37eaa36 /guix/import | |
parent | 0ab8ad46322bea331ed5f5592843ba35e7f38b37 (diff) | |
parent | 3089b70d766bd9ec70e1464867130b7b864fbe17 (diff) | |
download | guix-patches-18af6870370226b4d502d7372844e7f2aded5887.tar guix-patches-18af6870370226b4d502d7372844e7f2aded5887.tar.gz |
Merge branch 'master' into core-updates
Conflicts:
gnu/packages/icu4c.scm
gnu/packages/man.scm
gnu/packages/python-xyz.scm
guix/scripts/environment.scm
guix/scripts/pack.scm
guix/scripts/package.scm
guix/scripts/pull.scm
guix/store.scm
Diffstat (limited to 'guix/import')
-rw-r--r-- | guix/import/cran.scm | 97 | ||||
-rw-r--r-- | guix/import/crate.scm | 2 |
2 files changed, 79 insertions, 20 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index bb8226f714..53b930acd0 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,10 +38,14 @@ #: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)) + #:use-module (guix ui) #:use-module (guix upstream) #:use-module (guix packages) #:use-module (gnu packages) @@ -191,11 +196,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 +264,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 +436,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 +450,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 +467,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 +491,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 +538,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 +558,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 +577,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)) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 57823c3639..0b4482e876 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -112,7 +112,7 @@ record or #f if it was not found." (url (string-append (%crate-base-url) path))) (match (assoc-ref (or (json-fetch url) '()) "dependencies") ((? vector? vector) - (map json->crate-dependency (vector->list vector))) + (delete-duplicates (map json->crate-dependency (vector->list vector)))) (_ '())))) |