nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 2019-09-03 14:16:03 +02:00
parent 33f53947aa
commit d1dce0c363
No known key found for this signature in database
GPG Key ID: 634A8DFFD3F631DF
3 changed files with 159 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -221,6 +221,7 @@ MODULES = \
guix/import/gnu.scm \ guix/import/gnu.scm \
guix/import/hackage.scm \ guix/import/hackage.scm \
guix/import/json.scm \ guix/import/json.scm \
guix/import/kde.scm \
guix/import/launchpad.scm \ guix/import/launchpad.scm \
guix/import/opam.scm \ guix/import/opam.scm \
guix/import/print.scm \ guix/import/print.scm \

102
guix/gnu-maintenance.scm
View File

@ -1,7 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 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 © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -25,7 +24,6 @@
#:use-module (sxml simple) #:use-module (sxml simple)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -64,7 +62,6 @@
%gnu-updater %gnu-updater
%gnu-ftp-updater %gnu-ftp-updater
%kde-updater
%xorg-updater %xorg-updater
%kernel.org-updater)) %kernel.org-updater))
@ -615,98 +612,6 @@ releases are on gnu.org."
(define gnu-hosted? (define gnu-hosted?
(url-prefix-predicate "mirror://gnu/")) (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) (define (latest-xorg-release package)
"Return the latest release of PACKAGE, the name of an X.org package." "Return the latest release of PACKAGE, the name of an X.org package."
(let ((uri (string->uri (origin-uri (package-source package))))) (let ((uri (string->uri (origin-uri (package-source package)))))
@ -754,13 +659,6 @@ be determined."
(pure-gnu-package? package)))) (pure-gnu-package? package))))
(latest latest-release*))) (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 (define %xorg-updater
(upstream-updater (upstream-updater
(name 'xorg) (name 'xorg)

158
guix/import/kde.scm Normal file
View File

@ -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)))