upstream: Move KDE updater into a separate module.

As it was done for (guix import gnome).

* guix/import/kde.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/gnu-maintenance.scm (%kde-updater) (%kde-file-list-uri)
  (download.kde.org-files) (latest-kde-release): Remove.

2 files changed, 158 insertions, 102 deletions

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 9ce06508a3..ef067704ad 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,7 +1,6 @@
 ;;; 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.
 ;;;
@@ -25,7 +24,6 @@
   #: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)
@@ -64,7 +62,6 @@
 
             %gnu-updater
             %gnu-ftp-updater
-            %kde-updater
             %xorg-updater
             %kernel.org-updater))
 
@@ -615,98 +612,6 @@ 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, 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."
   (let ((uri (string->uri (origin-uri (package-source package)))))
@@ -754,13 +659,6 @@ be determined."
                 (pure-gnu-package? package))))
    (latest latest-release*)))
 
-(define %kde-updater
-  (upstream-updater
-    (name 'kde)
-    (description "Updater for KDE packages")
-    (pred (url-prefix-predicate "mirror://kde/"))
-    (latest latest-kde-release)))
-
 (define %xorg-updater
   (upstream-updater
    (name 'xorg)
diff --git a/guix/import/kde.scm b/guix/import/kde.scm
new file mode 100644
index 0000000000..927ecc8263
--- /dev/null
+++ b/guix/import/kde.scm
@@ -0,0 +1,158 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import kde)
+  #:use-module (guix http-client)
+  #:use-module (guix memoization)
+  #:use-module (guix gnu-maintenance)
+  #:use-module (guix packages)
+  #:use-module (guix upstream)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-11)
+  #:use-module (web uri)
+
+  #:export (%kde-updater))
+
+;;; Commentary:
+;;;
+;;; This package provides not an actual importer but simply an updater for
+;;; KDE packages.  It grabs available files from the 'ls-lR.bz2' file
+;;; available on download.kde.org.
+;;;
+;;; Code:
+
+(define (tarball->version tarball)
+  "Return the version TARBALL corresponds to.  TARBALL is a file name like
+\"coreutils-8.23.tar.xz\"."
+  (let-values (((name version)
+                (gnu-package-name->name+version
+                 (tarball-sans-extension tarball))))
+    version))
+
+(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,
+      ;; then prepend PATH
+      (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 '()))
+            ;; process a new directory block
+            (let ((path (read-line input)))
+              (if
+               (or (eof-object? path) (string= path ""))
+               (write (reverse files) cache)
+               (let loop_entries ((path (canonicalize path))
+                                  (files files))
+                 ;; process entries within the directory block
+                 (let ((line (read-line input)))
+                   (cond
+                    ((eof-object? line)
+                     (write (reverse files) cache))
+                    ((string-prefix? "-" line)
+                     ;; this is a file entry: prepend to FILES, then re-enter
+                     ;; the loop for remaining entries
+                     (loop_entries path
+                                   (cons (ls-lR-line->filename path line) files)
+                                   ))
+                    ((not (string= line ""))
+                     ;; this is a non-file entry: ignore it, just re-enter the
+                     ;; loop for remaining entries
+                     (loop_entries path files))
+                    ;; empty line: directory block end, re-enter the outer
+                    ;; loop for the next block
+                    (#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, 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 %kde-updater
+  (upstream-updater
+    (name 'kde)
+    (description "Updater for KDE packages")
+    (pred (url-prefix-predicate "mirror://kde/"))
+    (latest latest-kde-release)))