guix/import/kde.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 David Craven <david@craven.ch>
   3 ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix import kde)
  22   #:use-module (guix http-client)
  23   #:use-module (guix memoization)
  24   #:use-module (guix gnu-maintenance)
  25   #:use-module (guix packages)
  26   #:use-module (guix upstream)
  27   #:use-module (guix utils)
  28   #:use-module (ice-9 match)
  29   #:use-module (ice-9 rdelim)
  30   #:use-module (ice-9 regex)
  31   #:use-module (srfi srfi-11)
  32   #:use-module (web uri)
  33
  34   #:export (%kde-updater))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; This package provides not an actual importer but simply an updater for
  39 ;;; KDE packages.  It grabs available files from the 'ls-lR.bz2' file
  40 ;;; available on download.kde.org.
  41 ;;;
  42 ;;; Code:
  43
  44 (define (tarball->version tarball)
  45   "Return the version TARBALL corresponds to.  TARBALL is a file name like
  46 \"coreutils-8.23.tar.xz\"."
  47   (let-values (((name version)
  48                 (gnu-package-name->name+version
  49                  (tarball-sans-extension tarball))))
  50     version))
  51
  52 (define %kde-file-list-uri
  53   ;; URI of the file list (ls -lR format) for download.kde.org.
  54   (string->uri "https://download.kde.org/ls-lR.bz2"))
  55
  56 (define (download.kde.org-files)
  57   ;;"Return the list of files available at download.kde.org."
  58
  59     (define (ls-lR-line->filename path line)
  60       ;; Remove mode, blocks, user, group, size, date, time and one space,
  61       ;; then prepend PATH
  62       (regexp-substitute
  63        #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post))
  64
  65     (define (canonicalize path)
  66       (let* ((path (if (string-prefix? "/srv/archives/ftp/" path)
  67                        (string-drop path (string-length "/srv/archives/ftp"))
  68                        path))
  69              (path (if (string-suffix? ":" path)
  70                        (string-drop-right path 1)
  71                        path))
  72              (path (if (not (string-suffix? "/" path))
  73                        (string-append path "/")
  74                        path)))
  75         path))
  76
  77     (define (write-cache input cache)
  78       "Read bzipped ls-lR from INPUT, and write it as a list of file paths to
  79 CACHE."
  80       (call-with-decompressed-port 'bzip2 input
  81         (lambda (input)
  82           (let loop_dirs ((files '()))
  83             ;; process a new directory block
  84             (let ((path (read-line input)))
  85               (if
  86                (or (eof-object? path) (string= path ""))
  87                (write (reverse files) cache)
  88                (let loop_entries ((path (canonicalize path))
  89                                   (files files))
  90                  ;; process entries within the directory block
  91                  (let ((line (read-line input)))
  92                    (cond
  93                     ((eof-object? line)
  94                      (write (reverse files) cache))
  95                     ((string-prefix? "-" line)
  96                      ;; this is a file entry: prepend to FILES, then re-enter
  97                      ;; the loop for remaining entries
  98                      (loop_entries path
  99                                    (cons (ls-lR-line->filename path line) files)
 100                                    ))
 101                     ((not (string= line ""))
 102                      ;; this is a non-file entry: ignore it, just re-enter the
 103                      ;; loop for remaining entries
 104                      (loop_entries path files))
 105                     ;; empty line: directory block end, re-enter the outer
 106                     ;; loop for the next block
 107                     (#t (loop_dirs files)))))))))))
 108
 109   (define (cache-miss uri)
 110     (format (current-error-port) "fetching ~a...~%" (uri->string uri)))
 111
 112   (let* ((port (http-fetch/cached %kde-file-list-uri
 113                                   #:ttl 3600
 114                                   #:write-cache write-cache
 115                                   #:cache-miss cache-miss))
 116          (files (read port)))
 117     (close-port port)
 118     files))
 119
 120 (define (uri->kde-path-pattern uri)
 121   "Build a regexp from the package's URI suitable for matching the package
 122 path version-agnostic.
 123
 124 Example:
 125 Input:
 126    mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip
 127 Output:
 128    //stable/frameworks/[^/]+/portingAids/
 129 "
 130
 131   (define version-regexp
 132     ;; regexp for matching versions as used in the ld-lR file
 133     (make-regexp
 134      (string-join '("^([0-9]+\\.)+[0-9]+-?"   ;; 5.12.90, 4.2.0-preview
 135                     "^[0-9]+$"                ;; 20031002
 136                     ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1
 137                     "|")))
 138
 139   (define (version->pattern part)
 140     ;; If a path element might be a version, replace it by a catch-all part
 141     (if (regexp-exec version-regexp part)
 142         "[^/]+"
 143         part))
 144
 145   (let* ((path (uri-path uri))
 146          (directory-parts (string-split (dirname path) #\/)))
 147     (make-regexp
 148      (string-append
 149       (string-join (map version->pattern directory-parts) "/")
 150       "/"))))
 151
 152 (define (latest-kde-release package)
 153   "Return the latest release of PACKAGE, a KDE package, or #f if it could
 154 not be determined."
 155   (let* ((uri      (string->uri (origin-uri (package-source package))))
 156          (path-rx  (uri->kde-path-pattern uri))
 157          (name     (package-upstream-name package))
 158          (files    (download.kde.org-files))
 159          (relevant (filter (lambda (file)
 160                              (and (regexp-exec path-rx file)
 161                                   (release-file? name (basename file))))
 162                            files)))
 163     (match (sort relevant (lambda (file1 file2)
 164                             (version>? (tarball-sans-extension
 165                                         (basename file1))
 166                                        (tarball-sans-extension
 167                                         (basename file2)))))
 168            ((and tarballs (reference _ ...))
 169             (let* ((version  (tarball->version reference))
 170                    (tarballs (filter (lambda (file)
 171                                        (string=? (tarball-sans-extension
 172                                                   (basename file))
 173                                                  (tarball-sans-extension
 174                                                   (basename reference))))
 175                                      tarballs)))
 176               (upstream-source
 177                (package name)
 178                (version version)
 179                (urls (map (lambda (file)
 180                             (string-append "mirror://kde/" file))
 181                           tarballs)))))
 182            (()
 183             #f))))
 184
 185 (define %kde-updater
 186   (upstream-updater
 187     (name 'kde)
 188     (description "Updater for KDE packages")
 189     (pred (url-prefix-predicate "mirror://kde/"))
 190     (latest latest-kde-release)))