diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 124 | ||||
| -rw-r--r-- | guix/gnupg.scm | 152 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 137 | ||||
| -rw-r--r-- | guix/utils.scm | 6 |
5 files changed, 420 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index d1ae126f80..442e53e7f6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -33,6 +33,7 @@ MODULES = \ guix/scripts/hash.scm \ guix/scripts/pull.scm \ guix/scripts/substitute-binary.scm \ + guix/scripts/refresh.scm \ guix/base32.scm \ guix/utils.scm \ guix/serialization.scm \ @@ -47,6 +48,7 @@ MODULES = \ guix/build-system/perl.scm \ guix/build-system/trivial.scm \ guix/ftp-client.scm \ + guix/gnupg.scm \ guix/store.scm \ guix/ui.scm \ guix/build/download.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 0dc2fab092..619cb3106a 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -32,6 +32,12 @@ #:use-module (guix ui) #:use-module (guix utils) #: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 @@ -50,7 +56,10 @@ releases latest-release - gnu-package-name->name+version)) + gnu-package-name->name+version + package-update-path + package-update + update-package-source)) ;;; Commentary: ;;; @@ -234,6 +243,7 @@ stored." ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg") ("icecat" "ftp.gnu.org" "/gnu/gnuzilla") ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite") + ("glib" "ftp.gnome.org" "/pub/gnome/sources/glib") ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz"))) (match (assoc project quirks) @@ -320,4 +330,116 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (values name+version #f) (values (match:substring match 1) (match:substring match 2))))) + +;;; +;;; Auto-update. +;;; + +(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)) + ((name+version . directory) + (let-values (((_ new-version) + (package-name->name+version name+version))) + (and (version>? name+version (package-full-name package)) + `(,new-version . ,directory)))) + (_ #f)))) + +(define* (download-tarball store project directory version + #:optional (archive-type "gz")) + "Download PROJECT's tarball over FTP and check its OpenPGP signature. On +success, return the tarball file name." + (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))) + (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) + "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." + (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))) + (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~%") + name (package-location package)))))) + ;;; gnu-maintenance.scm ends here diff --git a/guix/gnupg.scm b/guix/gnupg.scm new file mode 100644 index 0000000000..ee67bea91b --- /dev/null +++ b/guix/gnupg.scm @@ -0,0 +1,152 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2010, 2011, 2013 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 gnupg) + #:use-module (ice-9 popen) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) + #:export (gnupg-verify + gnupg-verify* + gnupg-status-good-signature? + gnupg-status-missing-key?)) + +;;; Commentary: +;;; +;;; GnuPG interface. +;;; +;;; Code: + +(define %gpg-command "gpg2") +(define %openpgp-key-server "keys.gnupg.net") + +(define (gnupg-verify sig file) + "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed." + + (define (status-line->sexp line) + ;; See file `doc/DETAILS' in GnuPG. + (define sigid-rx + (make-regexp + "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)")) + (define goodsig-rx + (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$")) + (define validsig-rx + (make-regexp + "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) + (define expkeysig-rx ; good signature, but expired key + (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) + (define errsig-rx + (make-regexp + "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)")) + + (cond ((regexp-exec sigid-rx line) + => + (lambda (match) + `(signature-id ,(match:substring match 1) ; sig id + ,(match:substring match 2) ; date + ,(string->number ; timestamp + (match:substring match 3))))) + ((regexp-exec goodsig-rx line) + => + (lambda (match) + `(good-signature ,(match:substring match 1) ; key id + ,(match:substring match 2)))) ; user name + ((regexp-exec validsig-rx line) + => + (lambda (match) + `(valid-signature ,(match:substring match 1) ; fingerprint + ,(match:substring match 2) ; sig creation date + ,(string->number ; timestamp + (match:substring match 3))))) + ((regexp-exec expkeysig-rx line) + => + (lambda (match) + `(expired-key-signature ,(match:substring match 1) ; fingerprint + ,(match:substring match 2)))) ; user name + ((regexp-exec errsig-rx line) + => + (lambda (match) + `(signature-error ,(match:substring match 1) ; key id or fingerprint + ,(match:substring match 2) ; pubkey algo + ,(match:substring match 3) ; hash algo + ,(match:substring match 4) ; sig class + ,(string->number ; timestamp + (match:substring match 5)) + ,(let ((rc + (string->number ; return code + (match:substring match 6)))) + (case rc + ((9) 'missing-key) + ((4) 'unknown-algorithm) + (else rc)))))) + (else + `(unparsed-line ,line)))) + + (define (parse-status input) + (let loop ((line (read-line input)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line input) + (cons (status-line->sexp line) result))))) + + (let* ((pipe (open-pipe* OPEN_READ %gpg-command "--status-fd=1" + "--verify" sig file)) + (status (parse-status pipe))) + ;; Ignore PIPE's exit status since STATUS above should contain all the + ;; info we need. + (close-pipe pipe) + status)) + +(define (gnupg-status-good-signature? status) + "If STATUS, as returned by `gnupg-verify', denotes a good signature, return +a key-id/user pair; return #f otherwise." + (any (lambda (sexp) + (match sexp + (((or 'good-signature 'expired-key-signature) key-id user) + (cons key-id user)) + (_ #f))) + status)) + +(define (gnupg-status-missing-key? status) + "If STATUS denotes a missing-key error, then return the key-id of the +missing key." + (any (lambda (sexp) + (match sexp + (('signature-error key-id _ ...) + key-id) + (_ #f))) + status)) + +(define (gnupg-receive-keys key-id server) + (system* %gpg-command "--keyserver" server "--recv-keys" key-id)) + +(define* (gnupg-verify* sig file #:optional (server %openpgp-key-server)) + "Like `gnupg-verify', but try downloading the public key if it's missing. +Return #t if the signature was good, #f otherwise." + (let ((status (gnupg-verify sig file))) + (or (gnupg-status-good-signature? status) + (let ((missing (gnupg-status-missing-key? status))) + (and missing + (begin + ;; Download the missing key and try again. + (gnupg-receive-keys missing server) + (gnupg-status-good-signature? (gnupg-verify sig file)))))))) + +;;; gnupg.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm new file mode 100644 index 0000000000..036da38a3f --- /dev/null +++ b/guix/scripts/refresh.scm @@ -0,0 +1,137 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 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 scripts refresh) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix gnu-maintenance) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (rnrs io ports) + #:export (guix-refresh)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + '()) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix refresh"))))) + +(define (show-help) + (display (_ "Usage: guix refresh [OPTION]... PACKAGE... +Update package definitions to match the latest upstream version.\n")) + (display (_ " + -n, --dry-run do not build the derivations")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-refresh . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (dry-run? (assoc-ref opts 'dry-run?)) + (packages (match (concatenate + (filter-map (match-lambda + (('argument . value) + (let ((p (find-packages-by-name value))) + (unless p + (leave (_ "~a: no package by that name") + value)) + p)) + (_ #f)) + opts)) + (() ; default to all packages + ;; TODO: Keep only the newest of each package. + (fold-packages cons '())) + (some ; user-specified packages + some)))) + (with-error-handling + (if dry-run? + (for-each (lambda (package) + (match (false-if-exception (package-update-path package)) + ((new-version . directory) + (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))) + packages) + (let ((store (open-connection))) + (for-each (lambda (package) + (let-values (((version tarball) + (catch #t + (lambda () + (package-update store package)) + (lambda _ + (values #f #f)))) + ((loc) + (or (package-field-location package + 'version) + (package-location package)))) + (when version + (format (current-error-port) + (_ "~a: ~a: updating from version ~a to version ~a...~%") + (location->string loc) (package-name package) + (package-version package) version) + (let ((hash (call-with-input-file tarball + (compose sha256 get-bytevector-all)))) + (update-package-source package version hash))))) + packages)))))) diff --git a/guix/utils.scm b/guix/utils.scm index 4f399b95c3..3cbed2fd0f 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -60,6 +60,7 @@ version-compare version>? package-name->name+version + file-extension call-with-temporary-output-file fold2)) @@ -465,6 +466,11 @@ introduce the version part." ((head tail ...) (loop tail (cons head prefix)))))) +(define (file-extension file) + "Return the extension of FILE or #f if there is none." + (let ((dot (string-rindex file #\.))) + (and dot (substring file (+ 1 dot) (string-length file))))) + (define (call-with-temporary-output-file proc) "Call PROC with a name of a temporary file and open output port to that file; close the file and delete it when leaving the dynamic extent of this |