diff options
| -rw-r--r-- | guix/import/cran.scm | 148 | ||||
| -rw-r--r-- | guix/upstream.scm | 12 |
2 files changed, 124 insertions, 36 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 48fbc1dccb..31158f6b0e 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -32,6 +32,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module (ice-9 receive) #:use-module (web uri) #:use-module (guix memoization) @@ -49,6 +50,7 @@ with-directory-excursion)) #:use-module (guix utils) #:use-module (guix git) + #:use-module (guix git-download) #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) #:use-module (guix ui) #:use-module (guix upstream) @@ -187,10 +189,17 @@ package definition." (define %cran-url "https://cran.r-project.org/web/packages/") (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") +(define (bioconductor-git-url name) + (string-append "https://git.bioconductor.org/packages/" name)) ;; The latest Bioconductor release is 3.16. Bioconductor packages should be ;; updated together. (define %bioconductor-version "3.16") +(define %bioconductor-release-branch + (string-append "RELEASE_" + (string-map (match-lambda + (#\. #\_) + (chr chr)) %bioconductor-version))) (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -315,12 +324,26 @@ from ~a: ~a (~a)~%") (and (latest-bioconductor-package-version name 'annotation) 'annotation) (and (latest-bioconductor-package-version name 'experiment) 'experiment))) ;; TODO: Honor VERSION. - (version (latest-bioconductor-package-version name type)) - (url (car (bioconductor-uri name version type))) - (meta (fetch-description-from-tarball url))) - (if (boolean? type) - meta - (cons `(bioconductor-type . ,type) meta)))) + (version (latest-bioconductor-package-version name type))) + (cond + ((member type '(annotation experiment)) + ;; Download tarball + (and-let* ((url (car (bioconductor-uri name version type))) + (meta (fetch-description-from-tarball url))) + (cons `(bioconductor-type . ,type) meta))) + (else + (let ((url (bioconductor-git-url name))) + (call-with-values + (lambda () (download url + #:method 'git + #:ref (cons 'branch %bioconductor-release-branch))) + (lambda (dir commit) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (cons* `(git . ,url) + `(git-commit . ,commit) + meta)))))))))) ((git) (and (string-prefix? "http" name) ;; Download the git repository at "NAME" @@ -538,21 +561,28 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (source-url (case repository ((git) (assoc-ref meta 'git)) ((hg) (assoc-ref meta 'hg)) + ((bioconductor) + (or (assoc-ref meta 'git) + (match (apply uri-helper name version + (list (assoc-ref meta 'bioconductor-type))) + ((urls ...) urls) + ((? string? url) url) + (_ #f)))) (else - (match (apply uri-helper name version - (case repository - ((bioconductor) - (list (assoc-ref meta 'bioconductor-type))) - (else '()))) + (match (uri-helper name version) ((urls ...) urls) ((? string? url) url) (_ #f))))) (git? (if (assoc-ref meta 'git) #true #false)) (hg? (if (assoc-ref meta 'hg) #true #false)) - (source (download source-url #:method (cond - (git? 'git) - (hg? 'hg) - (else #f)))) + (source (download source-url + #:method (cond + (git? 'git) + (hg? 'hg) + (else #f)) + #:ref (and=> (assoc-ref meta 'git-commit) + (lambda (commit) + `(commit . ,commit))))) (sysdepends (append (if (needs-zlib? source (not (or git? hg?))) '("zlib") '()) (filter (lambda (name) @@ -571,7 +601,14 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (name ,(cran-guix-name name)) (version ,(cond (git? - `(git-version ,version revision commit)) + (case repository + ((bioconductor) + ;; Generate literal string for bioconductor git + ;; packages to allow the use of the automatic + ;; updater. + (git-version version "0" (assoc-ref meta 'git-commit))) + (else + `(git-version ,version revision commit)))) (hg? `(string-append ,version "-" revision "." changeset)) (else version))) @@ -605,11 +642,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (base32 ,(bytevector->nix-base32-string (file-hash* source #:recursive? (or git? hg?))))))) - ,@(if (not (and git? hg? - (equal? (string-append "r-" name) - (cran-guix-name name)))) - `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) - '()) + ,@(if (string=? (string-append "r-" name) + (cran-guix-name name)) + '() + `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))) (build-system r-build-system) ,@(maybe-inputs (map transform-sysname sysdepends)) ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) @@ -630,7 +666,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (license ,license)))) (values (cond - (git? + ((and git? (not (eq? repository 'bioconductor))) `(let ((commit ,(assoc-ref meta 'git-commit)) (revision "1")) ,package)) @@ -690,6 +726,9 @@ s-expression corresponding to that package, or #f on failure." ;; The URL ends on ;; (string-append "/" name "_" version ".tar.gz") (and start end (substring url (+ start 1) end)))) + ((? git-reference? uri) + (let ((url (git-reference-url uri))) + (last (string-split url #\/)))) (_ #f))) (_ #f))))) @@ -723,15 +762,53 @@ s-expression corresponding to that package, or #f on failure." (latest-bioconductor-package-version upstream-name)) (and version - ;; Bioconductor does not provide signatures. - (upstream-source - (package (package-name pkg)) - (version version) - (urls (bioconductor-uri upstream-name version)) - (input-changes - (changed-inputs - pkg - (cran->guix-package upstream-name #:repo 'bioconductor)))))) + ;; Data and experiment packages are not available through git. + (if (or (bioconductor-data-package? pkg) + (bioconductor-experiment-package? pkg)) + ;; Bioconductor does not provide signatures. + (upstream-source + (package (package-name pkg)) + (version version) + (urls (bioconductor-uri upstream-name version)) + (input-changes + (changed-inputs + pkg + (cran->guix-package upstream-name #:repo 'bioconductor)))) + + ;; Fetch from git. + (let* ((url (bioconductor-git-url upstream-name)) + (old-reference (origin-uri (package-source pkg))) + (old-commit (and (git-reference? old-reference) + (git-reference-commit old-reference))) + (directory new-commit + (download url + #:method 'git + #:ref (cons 'branch %bioconductor-release-branch))) + (revision (cond + ;; Do not upgrade + ((and old-commit + (string=? old-commit new-commit)) + #false) + ;; Increase revision number for same version + ((string-prefix? version (package-version pkg)) + (match (string-split (string-drop (package-version pkg) + (string-length version)) + (char-set #\- #\.)) + (("" old-revision commit-stub) + (number->string (1+ (string->number old-revision)))) + (_ "0"))) + ;; Reset revision on new version + (else "0"))) + (new-version + (if revision + (git-version version revision new-commit) + (package-version pkg)))) + (upstream-source + (package (package-name pkg)) + (version new-version) + (urls (git-reference + (url url) + (commit new-commit)))))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." @@ -753,7 +830,14 @@ s-expression corresponding to that package, or #f on failure." ;; Experiment packages are in a separate repository. (not (string-contains uri "/data/experiment/")))))) (and (string-prefix? "r-" (package-name package)) - ((url-predicate predicate) package)))) + (or (match (package-source package) + ((? origin? origin) + (and (eq? (origin-method origin) git-fetch) + (git-reference? (origin-uri origin)) + (string-prefix? "https://git.bioconductor.org" + (git-reference-url (origin-uri origin))))) + (_ #f)) + ((url-predicate predicate) package))))) (define (bioconductor-data-package? package) "Return true if PACKAGE is an R data package from Bioconductor." diff --git a/guix/upstream.scm b/guix/upstream.scm index 32736940aa..a9fb929081 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -504,11 +504,15 @@ values: 'always', 'never', and 'interactive' (default)." ((? upstream-source? source) (if (version>? (upstream-source-version source) (package-version package)) - (let ((method (match (package-source package) - ((? origin? origin) - (origin-method origin)) + (let ((method (match (upstream-source-urls source) + ((? git-reference? ref) + git-fetch) (_ - #f)))) + (match (package-source package) + ((? origin? origin) + (origin-method origin)) + (_ + #f)))))) (match (assq method %method-updates) (#f (raise (make-compound-condition |