ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add `guix refresh' and related auto-update tools.

Browse source 
* 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 2013-04-24 23:48:36 +02:00
parent f903dc056a
commit 0fdd3bea58
5 changed files with 420 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile.am
View file

@ -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 \

124
guix/gnu-maintenance.scm
View file

@ -32,6 +32,12 @@ (define-module (guix gnu-maintenance)
#: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 @@ (define-module (guix gnu-maintenance)
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 @@ (define quirks
("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 @@ (define (gnu-package-name->name+version name+version)
(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

152
guix/gnupg.scm Normal file
View file

@ -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

137
guix/scripts/refresh.scm Normal file
View file

@ -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))))))

6
guix/utils.scm
View file

@ -60,6 +60,7 @@ (define-module (guix utils)
version-compare
version>?
package-name->name+version
file-extension
call-with-temporary-output-file
fold2))
@ -465,6 +466,11 @@ (define number?
((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