summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/gnu-maintenance.scm67
1 files changed, 66 insertions, 1 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 07e6909641..7c7ca65d7b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -26,6 +26,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (rnrs io ports)
#:use-module (system foreign)
#:use-module (guix http-client)
#:use-module (guix ftp-client)
@@ -34,6 +35,7 @@
#:use-module (guix records)
#:use-module (guix upstream)
#:use-module (guix packages)
+ #:use-module (guix zlib)
#:export (gnu-package-name
gnu-package-mundane-name
gnu-package-copyright-holder
@@ -58,6 +60,7 @@
gnu-package-name->name+version
%gnu-updater
+ %gnu-ftp-updater
%gnome-updater
%kde-updater
%xorg-updater
@@ -433,6 +436,56 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
#:server server
#:directory directory))))
+(define %gnu-file-list-uri
+ ;; URI of the file list for ftp.gnu.org.
+ (string->uri "https://ftp.gnu.org/find.txt.gz"))
+
+(define ftp.gnu.org-files
+ (mlambda ()
+ "Return the list of files available at ftp.gnu.org."
+
+ ;; XXX: Memoize the whole procedure to work around the fact that
+ ;; 'http-fetch/cached' caches the gzipped version.
+
+ (define (trim-leading-components str)
+ ;; Trim the leading ".", if any, in "./gnu/foo".
+ (string-trim str (char-set #\.)))
+
+ (define (string->lines str)
+ (string-tokenize str (char-set-complement (char-set #\newline))))
+
+ (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 60 60))))
+ (map trim-leading-components
+ (call-with-gzip-input-port port
+ (compose string->lines get-string-all))))))
+
+(define (latest-gnu-release package)
+ "Return the latest release of PACKAGE, a GNU package available via
+ftp.gnu.org.
+
+This method does not rely on FTP access at all; instead, it browses the file
+list available from %GNU-FILE-LIST-URI over HTTP(S)."
+ (let-values (((server directory)
+ (ftp-server/directory package))
+ ((name)
+ (package-upstream-name package)))
+ (let* ((files (ftp.gnu.org-files))
+ (relevant (filter (lambda (file)
+ (and (string-contains file directory)
+ (release-file? name (basename file))
+ ))
+ files)))
+ (match (sort relevant (lambda (file1 file2)
+ (version>? (basename file1) (basename file2))))
+ ((tarball _ ...)
+ (upstream-source
+ (package name)
+ (version (tarball->version tarball))
+ (urls (list (string-append "mirror://gnu/" tarball)))
+ (signature-urls (map (cut string-append <> ".sig") urls))))
+ (()
+ #f)))))
+
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
@@ -557,10 +610,22 @@ source URLs starts with PREFIX."
".sign"))))))
(define %gnu-updater
+ ;; This is for everything at ftp.gnu.org.
(upstream-updater
(name 'gnu)
(description "Updater for GNU packages")
- (pred pure-gnu-package?)
+ (pred gnu-hosted?)
+ (latest latest-gnu-release)))
+
+(define %gnu-ftp-updater
+ ;; This is for GNU packages taken from alternate locations, such as
+ ;; alpha.gnu.org, ftp.gnupg.org, etc. It is obsolescent.
+ (upstream-updater
+ (name 'gnu-ftp)
+ (description "Updater for GNU packages only available via FTP")
+ (pred (lambda (package)
+ (and (not (gnu-hosted? package))
+ (pure-gnu-package? package))))
(latest latest-release*)))
(define %gnome-updater