[bug#36919,1/2] gnu-maintenance: KDE updater no longer relies on FTP access.
diff mbox series

Message ID 20190804102856.32609-2-h.goebel@crazy-compilers.com
State New
Headers show
Series
  • Make the KDE updater find packaes in subdirectories
Related show

Commit Message

Hartmut Goebel Aug. 4, 2019, 10:28 a.m. UTC
* 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 | 77 ++++++++++++++++++++++++++++++++++++----
 1 file changed, 70 insertions(+), 7 deletions(-)

Comments

Ludovic Courtès Aug. 17, 2019, 9:01 p.m. UTC | #1
Hi Hartmut,

Hartmut Goebel <h.goebel@crazy-compilers.com> skribis:

> * 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.

Nice!

How about moving this code to (guix import kde) as was done for (guix
import gnome) when we discussed it back then?  (See
<https://issues.guix.gnu.org/issue/28159>.)

> +(define download.kde.org-files
> +  (mlambda ()
> +    "Return the list of files available at download.kde.org."
> +    ;; XXX: Memoize the whole procedure to work around the fact that
> +    ;; 'http-fetch/cached' caches the bzip2-compressed version.
> +
> +    (define (canonicalize-path path)
> +      (if (string-prefix? "/srv/archives/ftp/" path)
> +          (set! path (string-drop path 17)))
> +      (if (string-suffix? ":" path)
> +          (set! path (string-drop-right path 1)))
> +      (if (not (string-suffix? "/" path))
> +          (set! path (string-append path "/")))
> +      path)

As a rule of thumb we don’t use ‘set!’ in Guix, except in special
circumstances.  In this case you can write:

  (define (canonicalize-path path)
    (cond ((string-prefix? …)
           (string-drop path 17))
          ((string-suffix? …)
           (string-drop-right path 1))
          …))

> +    (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))
> +
> +    (let ((entries `())
> +          (port (decompressed-port
> +                 'bzip2
> +                 (http-fetch/cached %kde-file-list-uri #:ttl 3600))))

What about passing ‘http-fetch/cached’ a custom #:write-cache, as is
done in (guix cve)?  That would allow us to store the cached file list
in a pre-processed (and possibly decompressed) format, speeding up
operation on cache hits.

> +      (do ((path (read-line port) (read-line port)))
> +          ((or (eof-object? path) (string= path "")))
> +        (set! path (canonicalize-path path))

I also recommend against ‘do’.  You can use a “named let” loop instead,
as in:

  (let loop ((files '()))
    (match (read-line port)
      ((? eof-object?)
       (reverse files))
      (line
       (loop (cons … files)))))

That’s about it.

Thanks!

Ludo’.

Patch
diff mbox series

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index d63d44f629..730e2519ee 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)
@@ -615,15 +617,76 @@  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
+  (mlambda ()
+    "Return the list of files available at download.kde.org."
+    ;; XXX: Memoize the whole procedure to work around the fact that
+    ;; 'http-fetch/cached' caches the bzip2-compressed version.
+
+    (define (canonicalize-path path)
+      (if (string-prefix? "/srv/archives/ftp/" path)
+          (set! path (string-drop path 17)))
+      (if (string-suffix? ":" path)
+          (set! path (string-drop-right path 1)))
+      (if (not (string-suffix? "/" path))
+          (set! path (string-append path "/")))
+      path)
+
+    (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))
+
+    (let ((entries `())
+          (port (decompressed-port
+                 'bzip2
+                 (http-fetch/cached %kde-file-list-uri #:ttl 3600))))
+      (do ((path (read-line port) (read-line port)))
+          ((or (eof-object? path) (string= path "")))
+        (set! path (canonicalize-path path))
+        (do ((line (read-line port) (read-line port)))
+            ((or (eof-object? line) (string= line "")))
+          (if (string-prefix? "-" line)
+              ;; regular file
+              (set! entries
+                    (cons (ls-lR-line->filename path line)
+                          entries)))))
+      entries)))
+
 (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))))))))
+  (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>? (sans-extension (basename file1))
+                                       (sans-extension (basename file2)))))
+           ((and tarballs (reference _ ...))
+            (let* ((version  (tarball->version reference))
+                   (tarballs (filter (lambda (file)
+                                       (string=? (sans-extension
+                                                  (basename file))
+                                                 (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."