summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-24 23:48:36 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-25 00:13:56 +0200
commit0fdd3bea58a872f2734c7d8747d7dbdd108d97d8 (patch)
tree368a1a86567c24d201c312efa2198b9d9246b9aa /guix
parentf903dc056a5176033daca7a69d5b2c8376ff0677 (diff)
downloadgnu-guix-0fdd3bea58a872f2734c7d8747d7dbdd108d97d8.tar
gnu-guix-0fdd3bea58a872f2734c7d8747d7dbdd108d97d8.tar.gz
Add `guix refresh' and related auto-update tools.
* guix/gnu-maintenance.scm (ftp-server/directory)[quirks]: Add glib. (package-update-path, download-tarball, package-update, update-package-source): New procedures. * guix/gnupg.scm, guix/scripts/refresh.scm: New files. * Makefile.am (MODULES): Add them. * guix/utils.scm (file-extension): New procedure.
Diffstat (limited to 'guix')
-rw-r--r--guix/gnu-maintenance.scm124
-rw-r--r--guix/gnupg.scm152
-rw-r--r--guix/scripts/refresh.scm137
-rw-r--r--guix/utils.scm6
4 files changed, 418 insertions, 1 deletions
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