[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: WIP
|
From: |
guix-commits |
|
Subject: |
01/01: WIP |
|
Date: |
Tue, 20 Dec 2022 05:08:01 -0500 (EST) |
rekado pushed a commit to branch wip-r
in repository guix.
commit e81a75a7b28c633a658ceeb0a728255674f56c58
Author: Ricardo Wurmus <rekado@elephly.net>
AuthorDate: Tue Sep 20 11:31:21 2022 +0200
WIP
---
guix/import/cran.scm | 148 ++++++++++++++++++++++++++++++++++++++++-----------
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