Browse Source

gnu-maintenance: Optimize `latest-release'.

* guix/gnu-maintenance.scm (tarball-regexp, sans-extension,
  release-file): New procedures.
  (%alpha-tarball-rx): New variable.
  (releases): Use them instead of local copies.
  (latest-release): Rewrite to not do a recursive search of all
  versions and instead jump directly to the latest.
wip-grafts
Ludovic Courtès 9 years ago
parent
commit
cac137aa84
  1. 87
      guix/gnu-maintenance.scm

87
guix/gnu-maintenance.scm

@ -252,30 +252,34 @@ stored."
(_
(values "ftp.gnu.org" (string-append "/gnu/" project)))))
(define tarball-regexp
(memoize
(lambda (project)
"Return a regexp matching tarball names for PROJECT."
(make-regexp (string-append "^" project
"-([0-9]|[^-])*(-src)?\\.tar\\.")))))
(define %alpha-tarball-rx
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
(define (sans-extension tarball)
"Return TARBALL without its .tar.* extension."
(let ((end (string-contains tarball ".tar")))
(substring tarball 0 end)))
(define (release-file project file)
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
PACKAGE-VERSION."
(and (not (string-suffix? ".sig" file))
(regexp-exec (tarball-regexp project) file)
(not (regexp-exec %alpha-tarball-rx file))
(let ((s (sans-extension file)))
(and (regexp-exec %package-name-rx s) s))))
(define (releases project)
"Return the list of releases of PROJECT as a list of release name/directory
pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
(define release-rx
(make-regexp (string-append "^" project
"-([0-9]|[^-])*(-src)?\\.tar\\.")))
(define alpha-rx
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
(define (sans-extension tarball)
(let ((end (string-contains tarball ".tar")))
(substring tarball 0 end)))
(define (release-file file)
;; Return #f if FILE is not a release tarball, otherwise return
;; PACKAGE-VERSION.
(and (not (string-suffix? ".sig" file))
(regexp-exec release-rx file)
(not (regexp-exec alpha-rx file))
(let ((s (sans-extension file)))
(and (regexp-exec %package-name-rx s) s))))
(let-values (((server directory) (ftp-server/directory project)))
(define conn (ftp-open server))
@ -301,7 +305,7 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
;; guile-www; in mit-scheme, filter out binaries.
(filter-map (match-lambda
((file 'file . _)
(and=> (release-file file)
(and=> (release-file project file)
(cut cons <> directory)))
(_ #f))
files)
@ -309,14 +313,39 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
(define (latest-release project)
"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
(let ((releases (releases project)))
(and (not (null? releases))
(fold (lambda (release latest)
(if (version>? (car release) (car latest))
release
latest))
'("" . "")
releases))))
(define (latest a b)
(if (version>? a b) a b))
(define contains-digit?
(cut string-any char-set:digit <>))
(let-values (((server directory) (ftp-server/directory project)))
(define conn (ftp-open server))
(let loop ((directory directory))
(let* ((entries (ftp-list conn directory))
(subdirs (filter-map (match-lambda
((dir 'directory . _) dir)
(_ #f))
entries)))
(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)))
(and=> (reduce latest #f files)
(cut cons <> directory))))
((subdirs ...)
;; Assume that SUBDIRS correspond to versions, and jump into the
;; one with the highest version number. Filter out sub-directories
;; that do not contain digits---e.g., /gnuzilla/lang.
(let* ((subdirs (filter contains-digit? subdirs))
(target (reduce latest #f subdirs)))
(and target
(loop (string-append directory "/" target))))))))))
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses

Loading…
Cancel
Save