diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 253 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 27 | ||||
| -rw-r--r-- | guix/upstream.scm | 259 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 2 |
5 files changed, 340 insertions, 202 deletions
diff --git a/Makefile.am b/Makefile.am index 6f785e7083..1427203fb2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -48,6 +48,7 @@ MODULES = \ guix/nar.scm \ guix/derivations.scm \ guix/gnu-maintenance.scm \ + guix/upstream.scm \ guix/licenses.scm \ guix/build-system.scm \ guix/build-system/cmake.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index e09df4b3ef..5af1b884ce 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -29,16 +29,10 @@ #:use-module (system foreign) #:use-module (guix http-client) #:use-module (guix ftp-client) - #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix records) + #:use-module (guix upstream) #:use-module (guix packages) - #:use-module ((guix download) #:select (download-to-store)) - #:use-module (guix gnupg) - #:use-module (rnrs io ports) - #:use-module (guix base32) - #:use-module ((guix build utils) - #:select (substitute)) #:export (gnu-package-name gnu-package-mundane-name gnu-package-copyright-holder @@ -56,21 +50,12 @@ find-packages gnu-package? - gnu-release? - gnu-release-package - gnu-release-version - gnu-release-directory - gnu-release-files - releases latest-release gnu-release-archive-types gnu-package-name->name+version - download-tarball - package-update-path - package-update - update-package-source)) + %gnu-updater)) ;;; Commentary: ;;; @@ -218,13 +203,6 @@ network to check in GNU's database." ;;; Latest release. ;;; -(define-record-type* <gnu-release> gnu-release make-gnu-release - gnu-release? - (package gnu-release-package) - (version gnu-release-version) - (directory gnu-release-directory) - (files gnu-release-files)) - (define (ftp-server/directory project) "Return the FTP server and directory where PROJECT's tarball are stored." @@ -284,29 +262,6 @@ true." (gnu-package-name->name+version (sans-extension tarball)))) version)) -(define (coalesce-releases releases) - "Coalesce the elements of RELEASES that correspond to the same version." - (define (same-version? r1 r2) - (string=? (gnu-release-version r1) (gnu-release-version r2))) - - (define (release>? r1 r2) - (version>? (gnu-release-version r1) (gnu-release-version r2))) - - (fold (lambda (release result) - (match result - ((head . tail) - (if (same-version? release head) - (cons (gnu-release - (inherit release) - (files (append (gnu-release-files release) - (gnu-release-files head)))) - tail) - (cons release result))) - (() - (list release)))) - '() - (sort releases release>?))) - (define (releases project) "Return the list of releases of PROJECT as a list of release name/directory pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). " @@ -319,13 +274,24 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (match directories (() (ftp-close conn) - (coalesce-releases result)) + (coalesce-sources result)) ((directory rest ...) (let* ((files (ftp-list conn directory)) (subdirs (filter-map (match-lambda - ((name 'directory . _) name) - (_ #f)) + ((name 'directory . _) name) + (_ #f)) files))) + (define (file->url file) + (string-append "ftp://" server directory "/" file)) + + (define (file->source file) + (let ((url (file->url file))) + (upstream-source + (package project) + (version (tarball->version file)) + (urls (list url)) + (signature-urls (list (string-append url ".sig")))))) + (loop (append (map (cut string-append directory "/" <>) subdirs) rest) @@ -335,15 +301,10 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). ;; in /gnu/guile, filter out guile-oops and ;; guile-www; in mit-scheme, filter out binaries. (filter-map (match-lambda - ((file 'file . _) - (if (release-file? project file) - (gnu-release - (package project) - (version (tarball->version file)) - (directory directory) - (files (list file))) - #f)) - (_ #f)) + ((file 'file . _) + (and (release-file? project file) + (file->source file))) + (_ #f)) files) result)))))))) @@ -355,7 +316,7 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (if (version>? a b) a b)) (define (latest-release a b) - (if (version>? (gnu-release-version a) (gnu-release-version b)) + (if (version>? (upstream-source-version a) (upstream-source-version b)) a b)) (define contains-digit? @@ -368,6 +329,17 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server)) + (define (file->url file) + (string-append "ftp://" server directory "/" file)) + + (define (file->source file) + (let ((url (file->url file))) + (upstream-source + (package project) + (version (tarball->version file)) + (urls (list url)) + (signature-urls (list (string-append url ".sig")))))) + (let loop ((directory directory) (result #f)) (let* ((entries (ftp-list conn directory)) @@ -375,12 +347,12 @@ open (resp. close) FTP connections; this can be useful to reuse connections." ;; Filter out sub-directories that do not contain digits---e.g., ;; /gnuzilla/lang and /gnupg/patches. (subdirs (filter-map (match-lambda - (((? patch-directory-name? dir) - 'directory . _) - #f) - (((? contains-digit? dir) 'directory . _) - dir) - (_ #f)) + (((? patch-directory-name? dir) + 'directory . _) + #f) + (((? contains-digit? dir) 'directory . _) + dir) + (_ #f)) entries)) ;; Whether or not SUBDIRS is empty, compute the latest releases @@ -390,19 +362,14 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (releases (filter-map (match-lambda ((file 'file . _) (and (release-file? project file) - (gnu-release - (package project) - (version - (tarball->version file)) - (directory directory) - (files (list file))))) + (file->source file))) (_ #f)) entries))) ;; Assume that SUBDIRS correspond to versions, and jump into the ;; one with the highest version number. (let* ((release (reduce latest-release #f - (coalesce-releases releases))) + (coalesce-sources releases))) (result (if (and result release) (latest-release release result) (or release result))) @@ -414,10 +381,18 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (ftp-close conn) result))))))) -(define (gnu-release-archive-types release) - "Return the available types of archives for RELEASE---a list of strings such -as \"gz\" or \"xz\"." - (map file-extension (gnu-release-files release))) +(define (latest-release* package) + "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE +is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that +name (this is the case for \"emacs-auctex\", for instance.)" + (catch 'ftp-error + (lambda () + (latest-release package)) + (lambda (key port . rest) + (if (ftp-connection? port) + (ftp-close port) + (close-port port)) + #f))) (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses @@ -431,121 +406,15 @@ as \"gz\" or \"xz\"." (values name+version #f) (values (match:substring match 1) (match:substring match 2))))) - -;;; -;;; Auto-update. -;;; +(define (non-emacs-gnu-package? package) + "Return true if PACKAGE is a non-Emacs GNU package. This excludes AucTeX, +for instance, whose releases are now uploaded to elpa.gnu.org." + (and (not (string-prefix? "emacs-" (package-name package))) + (gnu-package? package))) -(define (package-update-path package) - "Return an update path for PACKAGE, or #f if no update is needed." - (and (gnu-package? package) - (match (latest-release (package-name package)) - (($ <gnu-release> name version directory) - (and (version>? version (package-version package)) - `(,version . ,directory))) - (_ #f)))) - -(define* (download-tarball store project directory version - #:key (archive-type "gz") - (key-download 'interactive)) - "Download PROJECT's tarball over FTP and check its OpenPGP signature. On -success, return the tarball file name. KEY-DOWNLOAD specifies a download -policy for missing OpenPGP keys; allowed values: 'interactive' (default), -'always', and 'never'." - (let* ((server (ftp-server/directory project)) - (base (string-append project "-" version ".tar." archive-type)) - (url (string-append "ftp://" server "/" directory "/" base)) - (sig-url (string-append url ".sig")) - (tarball (download-to-store store url)) - (sig (download-to-store store sig-url))) - (let ((ret (gnupg-verify* sig tarball #:key-download key-download))) - (if ret - tarball - (begin - (warning (_ "signature verification failed for `~a'~%") - base) - (warning (_ "(could be because the public key is not in your keyring)~%")) - #f))))) - -(define* (package-update store package #:key (key-download 'interactive)) - "Return the new version and the file name of the new version tarball for -PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a -download policy for missing OpenPGP keys; allowed values: 'always', 'never', -and 'interactive' (default)." - (match (package-update-path package) - ((version . directory) - (let-values (((name) - (package-name package)) - ((archive-type) - (let ((source (package-source package))) - (or (and (origin? source) - (file-extension (origin-uri source))) - "gz")))) - (let ((tarball (download-tarball store name directory version - #:archive-type archive-type - #:key-download key-download))) - (values version tarball)))) - (_ - (values #f #f)))) - -(define (update-package-source package version hash) - "Modify the source file that defines PACKAGE to refer to VERSION, -whose tarball has SHA256 HASH (a bytevector). Return the new version string -if an update was made, and #f otherwise." - (define (new-line line matches replacement) - ;; Iterate over MATCHES and return the modified line based on LINE. - ;; Replace each match with REPLACEMENT. - (let loop ((m* matches) ; matches - (o 0) ; offset in L - (r '())) ; result - (match m* - (() - (let ((r (cons (substring line o) r))) - (string-concatenate-reverse r))) - ((m . rest) - (loop rest - (match:end m) - (cons* replacement - (substring line o (match:start m)) - r)))))) - - (define (update-source file old-version version - old-hash hash) - ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION - ;; and occurrences of OLD-HASH by HASH (base32 representation thereof). - - ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in - ;; different unrelated places, we may modify it more than needed, for - ;; instance. We should try to make changes only within the sexp that - ;; corresponds to the definition of PACKAGE. - (let ((old-hash (bytevector->nix-base32-string old-hash)) - (hash (bytevector->nix-base32-string hash))) - (substitute file - `((,(regexp-quote old-version) - . ,(cut new-line <> <> version)) - (,(regexp-quote old-hash) - . ,(cut new-line <> <> hash)))) - version)) - - (let ((name (package-name package)) - (loc (package-field-location package 'version))) - (if loc - (let ((old-version (package-version package)) - (old-hash (origin-sha256 (package-source package))) - (file (and=> (location-file loc) - (cut search-path %load-path <>)))) - (if file - (update-source file - old-version version - old-hash hash) - (begin - (warning (_ "~a: could not locate source file") - (location-file loc)) - #f))) - (begin - (format (current-error-port) - (_ "~a: ~a: no `version' field in source; skipping~%") - (location->string (package-location package)) - name))))) +(define %gnu-updater + (upstream-updater 'gnu + non-emacs-gnu-package? + latest-release*)) ;;; gnu-maintenance.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 097059e372..8d4f26e3b0 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -25,7 +25,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix gnu-maintenance) + #:use-module (guix upstream) + #:use-module ((guix gnu-maintenance) #:select (%gnu-updater)) #:use-module (guix gnupg) #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) @@ -124,6 +125,15 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) + +;;; +;;; Updates. +;;; + +(define %updaters + ;; List of "updaters" used by default. + (list %gnu-updater)) + (define* (update-package store package #:key (key-download 'interactive)) "Update the source file that defines PACKAGE with the new version. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed @@ -131,12 +141,12 @@ values: 'interactive' (default), 'always', and 'never'." (let-values (((version tarball) (catch #t (lambda () - (package-update store package #:key-download key-download)) + (package-update store package %updaters + #:key-download key-download)) (lambda _ (values #f #f)))) ((loc) - (or (package-field-location package - 'version) + (or (package-field-location package 'version) (package-location package)))) (when version (if (and=> tarball file-exists?) @@ -153,7 +163,6 @@ values: 'interactive' (default), 'always', and 'never'." downloaded and authenticated; not updating~%") (package-name package) version))))) - ;;; ;;; Entry point. @@ -262,14 +271,14 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" packages)))) (else (for-each (lambda (package) - (match (false-if-exception (package-update-path package)) - ((new-version . directory) + (match (package-update-path package %updaters) + ((? upstream-source? source) (let ((loc (or (package-field-location package 'version) (package-location package)))) (format (current-error-port) (_ "~a: ~a would be upgraded from ~a to ~a~%") (location->string loc) (package-name package) (package-version package) - new-version))) - (_ #f))) + (upstream-source-version source)))) + (#f #f))) packages)))))) diff --git a/guix/upstream.scm b/guix/upstream.scm new file mode 100644 index 0000000000..9300113ac6 --- /dev/null +++ b/guix/upstream.scm @@ -0,0 +1,259 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 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 upstream) + #:use-module (guix records) + #:use-module (guix utils) + #:use-module ((guix download) + #:select (download-to-store)) + #:use-module ((guix build utils) + #:select (substitute)) + #:use-module (guix gnupg) + #:use-module (guix packages) + #:use-module (guix ui) + #:use-module (guix base32) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:export (upstream-source + upstream-source? + upstream-source-package + upstream-source-version + upstream-source-urls + upstream-source-signature-urls + + coalesce-sources + + upstream-updater + upstream-updater? + upstream-updater-name + upstream-updater-predicate + upstream-updater-latest + + download-tarball + package-update-path + package-update + update-package-source)) + +;;; Commentary: +;;; +;;; This module provides tools to represent and manipulate a upstream source +;;; code, and to auto-update package recipes. +;;; +;;; Code: + +;; Representation of upstream's source. There can be several URLs--e.g., +;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per +;; source URL. +(define-record-type* <upstream-source> + upstream-source make-upstream-source + upstream-source? + (package upstream-source-package) ;string + (version upstream-source-version) ;string + (urls upstream-source-urls) ;list of strings + (signature-urls upstream-source-signature-urls ;#f | list of strings + (default #f))) + +(define (upstream-source-archive-types release) + "Return the available types of archives for RELEASE---a list of strings such +as \"gz\" or \"xz\"." + (map file-extension (upstream-source-urls release))) + +(define (coalesce-sources sources) + "Coalesce the elements of SOURCES, a list of <upstream-source>, that +correspond to the same version." + (define (same-version? r1 r2) + (string=? (upstream-source-version r1) (upstream-source-version r2))) + + (define (release>? r1 r2) + (version>? (upstream-source-version r1) (upstream-source-version r2))) + + (fold (lambda (release result) + (match result + ((head . tail) + (if (same-version? release head) + (cons (upstream-source + (inherit release) + (urls (append (upstream-source-urls release) + (upstream-source-urls head))) + (signature-urls + (append (upstream-source-signature-urls release) + (upstream-source-signature-urls head)))) + tail) + (cons release result))) + (() + (list release)))) + '() + (sort sources release>?))) + + +;;; +;;; Auto-update. +;;; + +(define-record-type <upstream-updater> + (upstream-updater name pred latest) + upstream-updater? + (name upstream-updater-name) + (pred upstream-updater-predicate) + (latest upstream-updater-latest)) + +(define (lookup-updater package updaters) + "Return an updater among UPDATERS that matches PACKAGE, or #f if none of +them matches." + (any (match-lambda + (($ <upstream-updater> _ pred latest) + (and (pred package) latest))) + updaters)) + +(define (package-update-path package updaters) + "Return an upstream source to update PACKAGE to, or #f if no update is +needed or known." + (match (lookup-updater package updaters) + ((? procedure? latest-release) + (match (latest-release (package-name package)) + ((and source ($ <upstream-source> name version)) + (and (version>? version (package-version package)) + source)) + (_ #f))) + (#f #f))) + +(define* (download-tarball store url signature-url + #:key (key-download 'interactive)) + "Download the tarball at URL to the store; check its OpenPGP signature at +SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball +file name. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; +allowed values: 'interactive' (default), 'always', and 'never'." + (let ((tarball (download-to-store store url))) + (if (not signature-url) + tarball + (let* ((sig (download-to-store store signature-url)) + (ret (gnupg-verify* sig tarball #:key-download key-download))) + (if ret + tarball + (begin + (warning (_ "signature verification failed for `~a'~%") + url) + (warning (_ "(could be because the public key is not in your keyring)~%")) + #f)))))) + +(define (find2 pred lst1 lst2) + "Like 'find', but operate on items from both LST1 and LST2. Return two +values: the item from LST1 and the item from LST2 that match PRED." + (let loop ((lst1 lst1) (lst2 lst2)) + (match lst1 + ((head1 . tail1) + (match lst2 + ((head2 . tail2) + (if (pred head1 head2) + (values head1 head2) + (loop tail1 tail2))))) + (() + (values #f #f))))) + +(define* (package-update store package updaters + #:key (key-download 'interactive)) + "Return the new version and the file name of the new version tarball for +PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a +download policy for missing OpenPGP keys; allowed values: 'always', 'never', +and 'interactive' (default)." + (match (package-update-path package updaters) + (($ <upstream-source> _ version urls signature-urls) + (let*-values (((name) + (package-name package)) + ((archive-type) + (match (and=> (package-source package) origin-uri) + ((? string? uri) + (or (file-extension uri) "gz")) + (_ + "gz"))) + ((url signature-url) + (find2 (lambda (url sig-url) + (string-suffix? archive-type url)) + urls + (or signature-urls (circular-list #f))))) + (let ((tarball (download-tarball store url signature-url + #:key-download key-download))) + (values version tarball)))) + (#f + (values #f #f)))) + +(define (update-package-source package version hash) + "Modify the source file that defines PACKAGE to refer to VERSION, +whose tarball has SHA256 HASH (a bytevector). Return the new version string +if an update was made, and #f otherwise." + (define (new-line line matches replacement) + ;; Iterate over MATCHES and return the modified line based on LINE. + ;; Replace each match with REPLACEMENT. + (let loop ((m* matches) ; matches + (o 0) ; offset in L + (r '())) ; result + (match m* + (() + (let ((r (cons (substring line o) r))) + (string-concatenate-reverse r))) + ((m . rest) + (loop rest + (match:end m) + (cons* replacement + (substring line o (match:start m)) + r)))))) + + (define (update-source file old-version version + old-hash hash) + ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION + ;; and occurrences of OLD-HASH by HASH (base32 representation thereof). + + ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in + ;; different unrelated places, we may modify it more than needed, for + ;; instance. We should try to make changes only within the sexp that + ;; corresponds to the definition of PACKAGE. + (let ((old-hash (bytevector->nix-base32-string old-hash)) + (hash (bytevector->nix-base32-string hash))) + (substitute file + `((,(regexp-quote old-version) + . ,(cut new-line <> <> version)) + (,(regexp-quote old-hash) + . ,(cut new-line <> <> hash)))) + version)) + + (let ((name (package-name package)) + (loc (package-field-location package 'version))) + (if loc + (let ((old-version (package-version package)) + (old-hash (origin-sha256 (package-source package))) + (file (and=> (location-file loc) + (cut search-path %load-path <>)))) + (if file + (update-source file + old-version version + old-hash hash) + (begin + (warning (_ "~a: could not locate source file") + (location-file loc)) + #f))) + (begin + (format (current-error-port) + (_ "~a: ~a: no `version' field in source; skipping~%") + (location->string (package-location package)) + name))))) + +;;; upstream.scm ends here diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index d9fc04495d..0c4e4f8443 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -23,7 +23,7 @@ guix/scripts/edit.scm guix/scripts/size.scm guix/scripts/graph.scm guix/scripts/challenge.scm -guix/gnu-maintenance.scm +guix/upstream.scm guix/ui.scm guix/http-client.scm guix/nar.scm |