diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 54 | ||||
| -rw-r--r-- | guix/import/gnome.scm | 112 |
3 files changed, 116 insertions, 51 deletions
diff --git a/Makefile.am b/Makefile.am index e35bdac306..2671065f68 100644 --- a/Makefile.am +++ b/Makefile.am @@ -151,6 +151,7 @@ MODULES = \ guix/import/hackage.scm \ guix/import/elpa.scm \ guix/import/texlive.scm \ + guix/import/gnome.scm \ guix/scripts.scm \ guix/scripts/download.scm \ guix/scripts/perform-download.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index cd7ffeaefd..0de36f2f71 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -61,7 +61,6 @@ %gnu-updater %gnu-ftp-updater - %gnome-updater %kde-updater %xorg-updater %kernel.org-updater)) @@ -512,6 +511,9 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)." (values name+version #f) (values (match:substring match 1) (match:substring match 2))))) +(define gnome-package? + (url-prefix-predicate "mirror://gnome/")) + (define (pure-gnu-package? package) "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This excludes AucTeX, for instance, whose releases are now uploaded to @@ -525,49 +527,6 @@ releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) -(define gnome-package? - (url-prefix-predicate "mirror://gnome/")) - -(define (latest-gnome-release package) - "Return the latest release of PACKAGE, the name of a GNOME package." - (define %not-dot - (char-set-complement (char-set #\.))) - - (define (even-minor-version? version) - (match (string-tokenize version %not-dot) - (((= string->number major) (= string->number minor) . rest) - (and minor (even? minor))) - (_ - #t))) ;cross fingers - - (define (even-numbered? file) - ;; Return true if FILE somehow denotes an even-numbered file name. The - ;; trick here is that we want this to match both directories such as - ;; "3.18.6" and actual file names such as "gtk+-3.18.6.tar.bz2". - (let-values (((name version) (package-name->name+version file))) - (even-minor-version? (or version name)))) - - (define upstream-name - ;; Some packages like "NetworkManager" have camel-case names. - (package-upstream-name package)) - - (false-if-ftp-error - (latest-ftp-release upstream-name - #:server "ftp.gnome.org" - #:directory (string-append "/pub/gnome/sources/" - upstream-name) - - - ;; <https://www.gnome.org/gnome-3/source/> explains - ;; that odd minor version numbers represent development - ;; releases, which we are usually not interested in. - #:keep-file? even-numbered? - - ;; ftp.gnome.org provides no signatures, only - ;; checksums. - #:file->signature (const #f)))) - - (define (latest-kde-release package) "Return the latest release of PACKAGE, the name of an KDE.org package." (let ((uri (string->uri (origin-uri (package-source package))))) @@ -624,13 +583,6 @@ releases are on gnu.org." (pure-gnu-package? package)))) (latest latest-release*))) -(define %gnome-updater - (upstream-updater - (name 'gnome) - (description "Updater for GNOME packages") - (pred gnome-package?) - (latest latest-gnome-release))) - (define %kde-updater (upstream-updater (name 'kde) diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm new file mode 100644 index 0000000000..1ade63e1af --- /dev/null +++ b/guix/import/gnome.scm @@ -0,0 +1,112 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 gnome) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix http-client) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (web uri) + #:use-module (ice-9 match) + #:export (%gnome-updater)) + +;;; Commentary: +;;; +;;; This package provides not an actual importer but simply an updater for +;;; GNOME packages. It grabs package meta-data from 'cache.json' files +;;; available on ftp.gnome.org. +;;; +;;; Code: + +(define (jsonish->upstream-source name jsonish) + "Return an <upstream-source> object for package NAME, using JSONISH as the +source for metadata." + (match jsonish + ((version . dictionary) + (upstream-source + (package name) + (version version) + (urls (filter-map (lambda (extension) + (match (hash-ref dictionary extension) + (#f + #f) + ((? string? relative-url) + (string-append "mirror://gnome/sources/" + name "/" relative-url)))) + '("tar.lz" "tar.xz" "tar.bz2" "tar.gz"))))))) + +(define (latest-gnome-release package) + "Return the latest release of PACKAGE, a GNOME package, or #f if it could +not be determined." + (define %not-dot + (char-set-complement (char-set #\.))) + + (define (even-minor-version? version) + (match (string-tokenize version %not-dot) + (((= string->number major) (= string->number minor) . rest) + (and minor (even? minor))) + (_ + #t))) ;cross fingers + + (define upstream-name + ;; Some packages like "NetworkManager" have camel-case names. + (package-upstream-name package)) + + (guard (c ((http-get-error? c) + (if (= 404 (http-get-error-code c)) + #f + (raise c)))) + (let* ((port (http-fetch/cached + (string->uri (string-append + "https://ftp.gnome.org/pub/gnome/sources/" + upstream-name "/cache.json")) + + ;; ftp.gnome.org supports 'if-Modified-Since', so the local + ;; cache can expire early. + #:ttl (* 60 10))) + (json (json->scm port))) + (close-port port) + (match json + ((4 (? hash-table? releases) _ ...) + (let* ((releases (hash-ref releases upstream-name)) + (latest (hash-fold (lambda (key value result) + (cond ((even-minor-version? key) + (match result + (#f + (cons key value)) + ((newest . _) + (if (version>? key newest) + (cons key value) + result)))) + (else + result))) + #f + releases))) + (and latest + (jsonish->upstream-source upstream-name latest)))))))) + +(define %gnome-updater + (upstream-updater + (name 'gnome) + (description "Updater for GNOME packages") + (pred (url-prefix-predicate "mirror://gnome/")) + (latest latest-gnome-release))) |