From 100b216d8a4218daec4a79024d62d54b52dc07be Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 3 Sep 2017 23:31:09 +0200
Subject: gnu-maintenance: GNU updater no longer relies on FTP access.

Partly fixes <https://bugs.gnu.org/28159>.
Suggested by Hartmut Goebel <h.goebel@crazy-compilers.com>.

* guix/gnu-maintenance.scm (%gnu-file-list-uri): New variable.
(ftp.gnu.org-files, latest-gnu-release): New procedures.
(%gnu-updater)[pred]: Change to GNU-HOSTED?.
[latest]: Change to LATEST-GNU-RELEASE.
(%gnu-ftp-updater): New variable.
---
 guix/gnu-maintenance.scm | 67 +++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 66 insertions(+), 1 deletion(-)

(limited to 'guix/gnu-maintenance.scm')

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
-- 
cgit v1.2.3