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:
Ludovic Courtès
parent
342b5204aa
commit
501d764751
|
|
@ -348,13 +348,16 @@ it."
|
|||
#:ftp-open ftp-open*
|
||||
#:ftp-close (const #f))
|
||||
(_ "looking for the latest release of GNU ~a...") name)
|
||||
((latest-version . _)
|
||||
(when (version>? latest-version full-name)
|
||||
(format (current-error-port)
|
||||
(_ "~a: note: using ~a \
|
||||
((? gnu-release? release)
|
||||
(let ((latest-version
|
||||
(string-append (gnu-release-package release) "-"
|
||||
(gnu-release-version release))))
|
||||
(when (version>? latest-version full-name)
|
||||
(format (current-error-port)
|
||||
(_ "~a: note: using ~a \
|
||||
but ~a is available upstream~%")
|
||||
(location->string (package-location package))
|
||||
full-name latest-version)))
|
||||
(location->string (package-location package))
|
||||
full-name latest-version))))
|
||||
(_ #t)))))
|
||||
(lambda (key . args)
|
||||
;; Silently ignore networking errors rather than preventing
|
||||
|
|
|
|||
|
|
@ -56,6 +56,12 @@
|
|||
find-packages
|
||||
gnu-package?
|
||||
|
||||
gnu-release?
|
||||
gnu-release-package
|
||||
gnu-release-version
|
||||
gnu-release-directory
|
||||
gnu-release-files
|
||||
|
||||
releases
|
||||
latest-release
|
||||
gnu-package-name->name+version
|
||||
|
|
@ -189,6 +195,13 @@ network to check in GNU's database."
|
|||
;;; 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)
|
||||
"Return the FTP server and directory where PROJECT's tarball are
|
||||
stored."
|
||||
|
|
@ -227,9 +240,9 @@ stored."
|
|||
(define %alpha-tarball-rx
|
||||
(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
|
||||
PACKAGE-VERSION."
|
||||
true."
|
||||
(and (not (string-suffix? ".sig" file))
|
||||
(and=> (regexp-exec %tarball-rx file)
|
||||
(lambda (match)
|
||||
|
|
@ -237,7 +250,37 @@ PACKAGE-VERSION."
|
|||
(equal? project (match:substring match 1))))
|
||||
(not (regexp-exec %alpha-tarball-rx 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)
|
||||
"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
|
||||
(()
|
||||
(ftp-close conn)
|
||||
result)
|
||||
(coalesce-releases result))
|
||||
((directory rest ...)
|
||||
(let* ((files (ftp-list conn directory))
|
||||
(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
|
||||
;; guile-www; in mit-scheme, filter out binaries.
|
||||
(filter-map (match-lambda
|
||||
((file 'file . _)
|
||||
(and=> (release-file project file)
|
||||
(cut cons <> directory)))
|
||||
(_ #f))
|
||||
((file 'file . _)
|
||||
(if (release-file? project file)
|
||||
(gnu-release
|
||||
(package project)
|
||||
(version (tarball->version file))
|
||||
(directory directory)
|
||||
(files (list file)))
|
||||
#f))
|
||||
(_ #f))
|
||||
files)
|
||||
result))))))))
|
||||
|
||||
|
|
@ -281,6 +329,10 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
|||
(define (latest 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?
|
||||
(cut string-any char-set:digit <>))
|
||||
|
||||
|
|
@ -307,14 +359,19 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
|||
(match subdirs
|
||||
(()
|
||||
;; No sub-directories, so assume that tarballs are here.
|
||||
(let ((files (filter-map (match-lambda
|
||||
((file 'file . _)
|
||||
(release-file project file))
|
||||
(_ #f))
|
||||
entries)))
|
||||
(let ((releases (filter-map (match-lambda
|
||||
((file 'file . _)
|
||||
(and (release-file? project file)
|
||||
(gnu-release
|
||||
(package project)
|
||||
(version
|
||||
(tarball->version file))
|
||||
(directory directory)
|
||||
(files (list file)))))
|
||||
(_ #f))
|
||||
entries)))
|
||||
(ftp-close conn)
|
||||
(and=> (reduce latest #f files)
|
||||
(cut cons <> directory))))
|
||||
(reduce latest-release #f (coalesce-releases releases))))
|
||||
((subdirs ...)
|
||||
;; Assume that SUBDIRS correspond to versions, and jump into the
|
||||
;; 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."
|
||||
(and (gnu-package? package)
|
||||
(match (latest-release (package-name package))
|
||||
((name+version . directory)
|
||||
(let-values (((_ new-version)
|
||||
(package-name->name+version name+version)))
|
||||
(and (version>? name+version (package-full-name package))
|
||||
`(,new-version . ,directory))))
|
||||
(($ <gnu-release> name version directory)
|
||||
(and (version>? version (package-version package))
|
||||
`(,version . ,directory)))
|
||||
(_ #f))))
|
||||
|
||||
(define* (download-tarball store project directory version
|
||||
|
|
|
|||
Loading…
Reference in New Issue