diff options
Diffstat (limited to 'guix/import/kde.scm')
| -rw-r--r-- | guix/import/kde.scm | 190 |
1 files changed, 190 insertions, 0 deletions
diff --git a/guix/import/kde.scm b/guix/import/kde.scm new file mode 100644 index 0000000000..6873418d62 --- /dev/null +++ b/guix/import/kde.scm @@ -0,0 +1,190 @@ +;;; 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 (uri->kde-path-pattern uri) + "Build a regexp from the package's URI suitable for matching the package +path version-agnostic. + +Example: +Input: + mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip +Output: + //stable/frameworks/[^/]+/portingAids/ +" + + (define version-regexp + ;; regexp for matching versions as used in the ld-lR file + (make-regexp + (string-join '("^([0-9]+\\.)+[0-9]+-?" ;; 5.12.90, 4.2.0-preview + "^[0-9]+$" ;; 20031002 + ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1 + "|"))) + + (define (version->pattern part) + ;; If a path element might be a version, replace it by a catch-all part + (if (regexp-exec version-regexp part) + "[^/]+" + part)) + + (let* ((path (uri-path uri)) + (directory-parts (string-split (dirname path) #\/))) + (make-regexp + (string-append + (string-join (map version->pattern directory-parts) "/") + "/")))) + +(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)))) + (path-rx (uri->kde-path-pattern uri)) + (name (package-upstream-name package)) + (files (download.kde.org-files)) + (relevant (filter (lambda (file) + (and (regexp-exec path-rx 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))) |