summaryrefslogtreecommitdiff
path: root/guix/import
diff options
context:
space:
mode:
Diffstat (limited to 'guix/import')
-rw-r--r--guix/import/cran.scm1
-rw-r--r--guix/import/crate.scm29
-rw-r--r--guix/import/github.scm2
-rw-r--r--guix/import/kde.scm190
-rw-r--r--guix/import/utils.scm17
5 files changed, 224 insertions, 15 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 35caa3e463..e47aff2b12 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -49,6 +49,7 @@
cran-recursive-import
%cran-updater
%bioconductor-updater
+ %bioconductor-version
cran-package?
bioconductor-package?
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index f6057dbf8b..fd1974eae8 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -181,9 +182,11 @@ and LICENSE."
;; This regexp matches that.
(make-regexp "^(.*) OR (.*)$"))
-(define (crate->guix-package crate-name)
+(define* (crate->guix-package crate-name #:optional version)
"Fetch the metadata for CRATE-NAME from crates.io, and return the
-`package' s-expression corresponding to that package, or #f on failure."
+`package' s-expression corresponding to that package, or #f on failure.
+When VERSION is specified, attempt to fetch that version; otherwise fetch the
+latest version of CRATE-NAME."
(define (string->license string)
(match (regexp-exec %dual-license-rx string)
(#f (list (spdx-string->license string)))
@@ -196,12 +199,18 @@ and LICENSE."
(define crate
(lookup-crate crate-name))
- (and crate
- (let* ((version (find (lambda (version)
- (string=? (crate-version-number version)
- (crate-latest-version crate)))
- (crate-versions crate)))
- (dependencies (crate-version-dependencies version))
+ (define version-number
+ (or version
+ (crate-latest-version crate)))
+
+ (define version*
+ (find (lambda (version)
+ (string=? (crate-version-number version)
+ version-number))
+ (crate-versions crate)))
+
+ (and crate version*
+ (let* ((dependencies (crate-version-dependencies version*))
(dep-crates (filter normal-dependency? dependencies))
(dev-dep-crates (remove normal-dependency? dependencies))
(cargo-inputs (sort (map crate-dependency-id dep-crates)
@@ -210,14 +219,14 @@ and LICENSE."
(sort (map crate-dependency-id dev-dep-crates)
string-ci<?)))
(make-crate-sexp #:name crate-name
- #:version (crate-version-number version)
+ #:version (crate-version-number version*)
#:cargo-inputs cargo-inputs
#:cargo-development-inputs cargo-development-inputs
#:home-page (or (crate-home-page crate)
(crate-repository crate))
#:synopsis (crate-description crate)
#:description (crate-description crate)
- #:license (and=> (crate-version-license version)
+ #:license (and=> (crate-version-license version*)
string->license)))))
(define (guix-package->crate-name package)
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 55e1f72a42..55ea00a111 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -161,7 +161,7 @@ empty list."
url))
(match (json-fetch (decorate release-url) #:headers headers)
- (()
+ (#()
;; We got the empty list, presumably because the user didn't use GitHub's
;; "release" mechanism, but hopefully they did use Git tags.
(json-fetch (decorate tag-url) #:headers headers))
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)))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 252875eeab..4694b6e7ef 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -212,10 +212,19 @@ with dashes."
(define (beautify-description description)
"Improve the package DESCRIPTION by turning a beginning sentence fragment
into a proper sentence and by using two spaces between sentences."
- (let ((cleaned (if (string-prefix? "A " description)
- (string-append "This package provides a"
- (substring description 1))
- description)))
+ (let ((cleaned (cond
+ ((string-prefix? "A " description)
+ (string-append "This package provides a"
+ (substring description 1)))
+ ((string-prefix? "Provides " description)
+ (string-append "This package provides"
+ (substring description
+ (string-length "Provides"))))
+ ((string-prefix? "Functions " description)
+ (string-append "This package provides functions"
+ (substring description
+ (string-length "Functions"))))
+ (else description))))
;; Use double spacing between sentences
(regexp-substitute/global #f "\\. \\b"
cleaned 'pre ". " 'post)))
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-17 23:59:23 +0000