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.
This commit is contained in:
Ludovic Courtès
parent
f903dc056a
commit
0fdd3bea58
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue