summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorHartmut Goebel <h.goebel@crazy-compilers.com>2019-08-04 11:30:32 +0200
committerHartmut Goebel <h.goebel@crazy-compilers.com>2019-09-10 19:04:06 +0200
commit33f53947aa6d50ef7fe08c0ef9e32cdb9e77db89 (patch)
treed46c712a08b115285f0cd93349816c47caab3dc2 /guix
parentda1027a70508ea96134f5ef89d9dd390679255f0 (diff)
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.
Diffstat (limited to 'guix')
-rw-r--r--guix/gnu-maintenance.scm100
1 files 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."