From 33f53947aa6d50ef7fe08c0ef9e32cdb9e77db89 Mon Sep 17 00:00:00 2001
From: Hartmut Goebel <h.goebel@crazy-compilers.com>
Date: Sun, 4 Aug 2019 11:30:32 +0200
Subject: [PATCH] gnu-maintenance: KDE updater no longer relies on FTP access.

Fetch the ls-lR.bz2 file list for download.kde.org, convert it into a list of
file paths and cache the list.

* guix/gnu-maintenance.scm (%kde-file-list-uri): New variable.
  (download.kde.org-files): New procedure.
  (latest-kde-release): Change to use DOWNLOAD.KDE.ORG-FILES and search
  for files in this list.
---
 guix/gnu-maintenance.scm | 100 +++++++++++++++++++++++++++++++++++----
 1 file changed, 92 insertions(+), 8 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 8fce956c60..9ce06508a3 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +25,7 @@
   #:use-module (sxml simple)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -613,15 +615,97 @@ releases are on gnu.org."
 (define gnu-hosted?
   (url-prefix-predicate "mirror://gnu/"))
 
+(define %kde-file-list-uri
+  ;; URI of the file list (ls -lR format) for download.kde.org.
+  (string->uri "https://download.kde.org/ls-lR.bz2"))
+
+(define (download.kde.org-files)
+  ;;"Return the list of files available at download.kde.org."
+
+  (define (ls-lR-line->filename path line)
+    ;; remove mode, blocks, user, group, size, date, time and one space
+    (regexp-substitute
+     #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post))
+
+  (define (canonicalize path)
+    (let* ((path (if (string-prefix? "/srv/archives/ftp/" path)
+                     (string-drop path (string-length "/srv/archives/ftp"))
+                     path))
+           (path (if (string-suffix? ":" path)
+                     (string-drop-right path 1)
+                     path))
+           (path (if (not (string-suffix? "/" path))
+                     (string-append path "/")
+                     path)))
+      path))
+
+  (define (write-cache input cache)
+    "Read bzipped ls-lR from INPUT, and write it as a list of file paths to
+CACHE."
+
+    (call-with-decompressed-port 'bzip2 input
+      (lambda (input)
+        (let loop_dirs ((files '()))
+          (let ((path (read-line input)))
+            (if
+             (or (eof-object? path) (string= path ""))
+             (write (reverse files) cache))
+            (let loop_entries ((path (canonicalize path))
+                               (files files))
+              (let ((line (read-line input)))
+                (cond
+                 ((eof-object? line)
+                  (write (reverse files) cache))
+                 ((string-prefix? "-" line)
+                  (loop_entries path
+                                (cons (ls-lR-line->filename path line) files)))
+                 ((not (string= line ""))
+                  (loop_entries path files))
+                 (#t (loop_dirs files))))))))))
+
+  (define (cache-miss uri)
+    (format (current-error-port) "fetching ~a...~%" (uri->string uri)))
+
+  (let* ((port (http-fetch/cached %kde-file-list-uri
+                                  #:ttl 3600
+                                  #:write-cache write-cache
+                                  #:cache-miss cache-miss))
+         (files (read port)))
+    (close-port port)
+    files))
+
 (define (latest-kde-release package)
-  "Return the latest release of PACKAGE, the name of an KDE.org package."
-  (let ((uri (string->uri (origin-uri (package-source package)))))
-    (false-if-ftp-error
-     (latest-ftp-release
-      (package-upstream-name package)
-      #:server "ftp.mirrorservice.org"
-      #:directory (string-append "/sites/ftp.kde.org/pub/kde/"
-                                 (dirname (dirname (uri-path uri))))))))
+  "Return the latest release of PACKAGE, a KDE package, or #f if it could not
+be determined."
+  (let* ((uri      (string->uri (origin-uri (package-source package))))
+         (directory  (dirname (dirname (uri-path uri))))
+         (name     (package-upstream-name package))
+         (files    (download.kde.org-files))
+         (relevant (filter (lambda (file)
+                             (and (string-prefix? directory file)
+                                  (release-file? name (basename file))))
+                           files)))
+    (match (sort relevant (lambda (file1 file2)
+                            (version>? (tarball-sans-extension
+                                        (basename file1))
+                                       (tarball-sans-extension
+                                        (basename file2)))))
+           ((and tarballs (reference _ ...))
+            (let* ((version  (tarball->version reference))
+                   (tarballs (filter (lambda (file)
+                                       (string=? (tarball-sans-extension
+                                                  (basename file))
+                                                 (tarball-sans-extension
+                                                  (basename reference))))
+                                     tarballs)))
+              (upstream-source
+               (package name)
+               (version version)
+               (urls (map (lambda (file)
+                            (string-append "mirror://kde/" file))
+                          tarballs)))))
+           (()
+            #f))))
 
 (define (latest-xorg-release package)
   "Return the latest release of PACKAGE, the name of an X.org package."