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.
This commit is contained in:
Hartmut Goebel
parent
33f53947aa
commit
d1dce0c363
|
|
@ -221,6 +221,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 \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
Loading…
Reference in New Issue