guix-devel/guix/import/kde.scm

191 lines
7.3 KiB
Scheme

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