From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:58616) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1huDm9-0006oA-1U for guix-patches@gnu.org; Sun, 04 Aug 2019 06:30:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1huDm7-0006hB-49 for guix-patches@gnu.org; Sun, 04 Aug 2019 06:30:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:51654) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1huDm6-0006fC-Km for guix-patches@gnu.org; Sun, 04 Aug 2019 06:30:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1huDm6-0006QO-Eq for guix-patches@gnu.org; Sun, 04 Aug 2019 06:30:02 -0400 Subject: [bug#36919] [PATCH 1/2] gnu-maintenance: KDE updater no longer relies on FTP access. Resent-Message-ID: From: Hartmut Goebel Date: Sun, 4 Aug 2019 12:28:55 +0200 Message-Id: <20190804102856.32609-2-h.goebel@crazy-compilers.com> In-Reply-To: <20190804102856.32609-1-h.goebel@crazy-compilers.com> References: <20190804102856.32609-1-h.goebel@crazy-compilers.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 36919@debbugs.gnu.org * 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(-) 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 ;;; Copyright © 2012, 2013 Nikita Karetnikov +;;; Copyright © 2019 Hartmut Goebel ;;; ;;; 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." -- 2.21.0