gnu-maintenance: Introduce <gnu-release> data type.
* guix/gnu-maintenance.scm (<gnu-release>): New record type. (release-file): Rename to... (release-file?): ... this. Return a Boolean. (tarball->version, coalesce-releases): New procedures. (releases): Call 'coalesce-releases' on RESULT. Return <gnu-release> objects instead of pairs. (latest-release): Likewise. (package-update-path): Adjust accordingly. * gnu/packages.scm (check-package-freshness): Adjust accordingly.
This commit is contained in:
parent
342b5204aa
commit
501d764751
|
@ -348,13 +348,16 @@ it."
|
||||||
#:ftp-open ftp-open*
|
#:ftp-open ftp-open*
|
||||||
#:ftp-close (const #f))
|
#:ftp-close (const #f))
|
||||||
(_ "looking for the latest release of GNU ~a...") name)
|
(_ "looking for the latest release of GNU ~a...") name)
|
||||||
((latest-version . _)
|
((? gnu-release? release)
|
||||||
(when (version>? latest-version full-name)
|
(let ((latest-version
|
||||||
(format (current-error-port)
|
(string-append (gnu-release-package release) "-"
|
||||||
(_ "~a: note: using ~a \
|
(gnu-release-version release))))
|
||||||
|
(when (version>? latest-version full-name)
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "~a: note: using ~a \
|
||||||
but ~a is available upstream~%")
|
but ~a is available upstream~%")
|
||||||
(location->string (package-location package))
|
(location->string (package-location package))
|
||||||
full-name latest-version)))
|
full-name latest-version))))
|
||||||
(_ #t)))))
|
(_ #t)))))
|
||||||
(lambda (key . args)
|
(lambda (key . args)
|
||||||
;; Silently ignore networking errors rather than preventing
|
;; Silently ignore networking errors rather than preventing
|
||||||
|
|
|
@ -56,6 +56,12 @@
|
||||||
find-packages
|
find-packages
|
||||||
gnu-package?
|
gnu-package?
|
||||||
|
|
||||||
|
gnu-release?
|
||||||
|
gnu-release-package
|
||||||
|
gnu-release-version
|
||||||
|
gnu-release-directory
|
||||||
|
gnu-release-files
|
||||||
|
|
||||||
releases
|
releases
|
||||||
latest-release
|
latest-release
|
||||||
gnu-package-name->name+version
|
gnu-package-name->name+version
|
||||||
|
@ -189,6 +195,13 @@ network to check in GNU's database."
|
||||||
;;; Latest release.
|
;;; Latest release.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
(define-record-type* <gnu-release> gnu-release make-gnu-release
|
||||||
|
gnu-release?
|
||||||
|
(package gnu-release-package)
|
||||||
|
(version gnu-release-version)
|
||||||
|
(directory gnu-release-directory)
|
||||||
|
(files gnu-release-files))
|
||||||
|
|
||||||
(define (ftp-server/directory project)
|
(define (ftp-server/directory project)
|
||||||
"Return the FTP server and directory where PROJECT's tarball are
|
"Return the FTP server and directory where PROJECT's tarball are
|
||||||
stored."
|
stored."
|
||||||
|
@ -227,9 +240,9 @@ stored."
|
||||||
(define %alpha-tarball-rx
|
(define %alpha-tarball-rx
|
||||||
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
|
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
|
||||||
|
|
||||||
(define (release-file project file)
|
(define (release-file? project file)
|
||||||
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
|
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
|
||||||
PACKAGE-VERSION."
|
true."
|
||||||
(and (not (string-suffix? ".sig" file))
|
(and (not (string-suffix? ".sig" file))
|
||||||
(and=> (regexp-exec %tarball-rx file)
|
(and=> (regexp-exec %tarball-rx file)
|
||||||
(lambda (match)
|
(lambda (match)
|
||||||
|
@ -237,7 +250,37 @@ PACKAGE-VERSION."
|
||||||
(equal? project (match:substring match 1))))
|
(equal? project (match:substring match 1))))
|
||||||
(not (regexp-exec %alpha-tarball-rx file))
|
(not (regexp-exec %alpha-tarball-rx file))
|
||||||
(let ((s (sans-extension file)))
|
(let ((s (sans-extension file)))
|
||||||
(and (regexp-exec %package-name-rx s) s))))
|
(regexp-exec %package-name-rx s))))
|
||||||
|
|
||||||
|
(define (tarball->version tarball)
|
||||||
|
"Return the version TARBALL corresponds to. TARBALL is a file name like
|
||||||
|
\"coreutils-8.23.tar.xz\"."
|
||||||
|
(let-values (((name version)
|
||||||
|
(gnu-package-name->name+version (sans-extension tarball))))
|
||||||
|
version))
|
||||||
|
|
||||||
|
(define (coalesce-releases releases)
|
||||||
|
"Coalesce the elements of RELEASES that correspond to the same version."
|
||||||
|
(define (same-version? r1 r2)
|
||||||
|
(string=? (gnu-release-version r1) (gnu-release-version r2)))
|
||||||
|
|
||||||
|
(define (release>? r1 r2)
|
||||||
|
(version>? (gnu-release-version r1) (gnu-release-version r2)))
|
||||||
|
|
||||||
|
(fold (lambda (release result)
|
||||||
|
(match result
|
||||||
|
((head . tail)
|
||||||
|
(if (same-version? release head)
|
||||||
|
(cons (gnu-release
|
||||||
|
(inherit release)
|
||||||
|
(files (append (gnu-release-files release)
|
||||||
|
(gnu-release-files head))))
|
||||||
|
tail)
|
||||||
|
(cons release result)))
|
||||||
|
(()
|
||||||
|
(list release))))
|
||||||
|
'()
|
||||||
|
(sort releases release>?)))
|
||||||
|
|
||||||
(define (releases project)
|
(define (releases project)
|
||||||
"Return the list of releases of PROJECT as a list of release name/directory
|
"Return the list of releases of PROJECT as a list of release name/directory
|
||||||
|
@ -251,7 +294,7 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
|
||||||
(match directories
|
(match directories
|
||||||
(()
|
(()
|
||||||
(ftp-close conn)
|
(ftp-close conn)
|
||||||
result)
|
(coalesce-releases result))
|
||||||
((directory rest ...)
|
((directory rest ...)
|
||||||
(let* ((files (ftp-list conn directory))
|
(let* ((files (ftp-list conn directory))
|
||||||
(subdirs (filter-map (match-lambda
|
(subdirs (filter-map (match-lambda
|
||||||
|
@ -267,10 +310,15 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
|
||||||
;; in /gnu/guile, filter out guile-oops and
|
;; in /gnu/guile, filter out guile-oops and
|
||||||
;; guile-www; in mit-scheme, filter out binaries.
|
;; guile-www; in mit-scheme, filter out binaries.
|
||||||
(filter-map (match-lambda
|
(filter-map (match-lambda
|
||||||
((file 'file . _)
|
((file 'file . _)
|
||||||
(and=> (release-file project file)
|
(if (release-file? project file)
|
||||||
(cut cons <> directory)))
|
(gnu-release
|
||||||
(_ #f))
|
(package project)
|
||||||
|
(version (tarball->version file))
|
||||||
|
(directory directory)
|
||||||
|
(files (list file)))
|
||||||
|
#f))
|
||||||
|
(_ #f))
|
||||||
files)
|
files)
|
||||||
result))))))))
|
result))))))))
|
||||||
|
|
||||||
|
@ -281,6 +329,10 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
||||||
(define (latest a b)
|
(define (latest a b)
|
||||||
(if (version>? a b) a b))
|
(if (version>? a b) a b))
|
||||||
|
|
||||||
|
(define (latest-release a b)
|
||||||
|
(if (version>? (gnu-release-version a) (gnu-release-version b))
|
||||||
|
a b))
|
||||||
|
|
||||||
(define contains-digit?
|
(define contains-digit?
|
||||||
(cut string-any char-set:digit <>))
|
(cut string-any char-set:digit <>))
|
||||||
|
|
||||||
|
@ -307,14 +359,19 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
||||||
(match subdirs
|
(match subdirs
|
||||||
(()
|
(()
|
||||||
;; No sub-directories, so assume that tarballs are here.
|
;; No sub-directories, so assume that tarballs are here.
|
||||||
(let ((files (filter-map (match-lambda
|
(let ((releases (filter-map (match-lambda
|
||||||
((file 'file . _)
|
((file 'file . _)
|
||||||
(release-file project file))
|
(and (release-file? project file)
|
||||||
(_ #f))
|
(gnu-release
|
||||||
entries)))
|
(package project)
|
||||||
|
(version
|
||||||
|
(tarball->version file))
|
||||||
|
(directory directory)
|
||||||
|
(files (list file)))))
|
||||||
|
(_ #f))
|
||||||
|
entries)))
|
||||||
(ftp-close conn)
|
(ftp-close conn)
|
||||||
(and=> (reduce latest #f files)
|
(reduce latest-release #f (coalesce-releases releases))))
|
||||||
(cut cons <> directory))))
|
|
||||||
((subdirs ...)
|
((subdirs ...)
|
||||||
;; Assume that SUBDIRS correspond to versions, and jump into the
|
;; Assume that SUBDIRS correspond to versions, and jump into the
|
||||||
;; one with the highest version number.
|
;; one with the highest version number.
|
||||||
|
@ -346,11 +403,9 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
||||||
"Return an update path for PACKAGE, or #f if no update is needed."
|
"Return an update path for PACKAGE, or #f if no update is needed."
|
||||||
(and (gnu-package? package)
|
(and (gnu-package? package)
|
||||||
(match (latest-release (package-name package))
|
(match (latest-release (package-name package))
|
||||||
((name+version . directory)
|
(($ <gnu-release> name version directory)
|
||||||
(let-values (((_ new-version)
|
(and (version>? version (package-version package))
|
||||||
(package-name->name+version name+version)))
|
`(,version . ,directory)))
|
||||||
(and (version>? name+version (package-full-name package))
|
|
||||||
`(,new-version . ,directory))))
|
|
||||||
(_ #f))))
|
(_ #f))))
|
||||||
|
|
||||||
(define* (download-tarball store project directory version
|
(define* (download-tarball store project directory version
|
||||||
|
|
Loading…
Reference in New Issue