[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#36919] [Patch v2 3/4] upstream: Move KDE updater into a separate mo
|
From: |
Hartmut Goebel |
|
Subject: |
[bug#36919] [Patch v2 3/4] upstream: Move KDE updater into a separate module. |
|
Date: |
Tue, 3 Sep 2019 14:24:48 +0200 |
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.
---
Makefile.am | 1 +
guix/gnu-maintenance.scm | 102 -------------------------
guix/import/kde.scm | 158 +++++++++++++++++++++++++++++++++++++++
3 files changed, 159 insertions(+), 102 deletions(-)
create mode 100644 guix/import/kde.scm
diff --git a/Makefile.am b/Makefile.am
index fa6bf8fe80..c8366c0421 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -218,6 +218,7 @@ MODULES = \
guix/import/gnu.scm \
guix/import/hackage.scm \
guix/import/json.scm \
+ guix/import/kde.scm \
guix/import/launchpad.scm \
guix/import/opam.scm \
guix/import/print.scm \
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 <address@hidden>
;;; Copyright © 2012, 2013 Nikita Karetnikov <address@hidden>
-;;; Copyright © 2019 Hartmut Goebel <address@hidden>
;;;
;;; 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 <address@hidden>
+;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2019 Hartmut Goebel <address@hidden>
+;;;
+;;; 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)))
--
2.21.0