diff options
| -rw-r--r-- | guix/gnu-maintenance.scm | 87 |
1 files changed, 58 insertions, 29 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 619cb3106a..49b10565db 100644 --- a/guix/gnu-maintenance.scm +++ b/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 |