Browse Source
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.wip-system-bootstrap
Hartmut Goebel
3 years ago
3 changed files with 159 additions and 102 deletions
@ -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