nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

guix refresh: Add '--key-download'. 

* guix/gnu-maintenance.scm (download-tarball): Add a 'key-download'
  keyword argument and pass it to 'gnupg-verify*'.  Make
  'archive-type' a keyword argument.
  (package-update): Add a 'key-download' keyword argument.  Pass
  'archive-type' and 'key-download' keyword arguments to
  'download-tarball'.

* guix/gnupg.scm: Import (ice-9 i18n) and (guix ui).
  (gnupg-verify*): Add a 'key-download' keyword argument and adjust
  'gnupg-verify*' to use it.  Make 'server' a keyword argument.

* guix/scripts/refresh.scm (show-help, %options): Add and document
  '--key-download'.
  (update-package): Add a 'key-download' keyword argument and pass it
  to 'package-update'.
  (guix-refresh): Pass 'key-download' to 'update-package'.  Limit
  lines to a maximum of 79 characters.
This commit is contained in:
Nikita Karetnikov 2013-06-10 07:46:13 +00:00
parent e20ec9cc51
commit 392b5d8cab
3 changed files with 92 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
guix/gnu-maintenance.scm
View File

@ -341,16 +341,19 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
(_ #f)))) (_ #f))))
(define* (download-tarball store project directory version (define* (download-tarball store project directory version
#:optional (archive-type "gz")) #:key (archive-type "gz")
(key-download 'interactive))
"Download PROJECT's tarball over FTP and check its OpenPGP signature. On "Download PROJECT's tarball over FTP and check its OpenPGP signature. On
success, return the tarball file name." 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)) (let* ((server (ftp-server/directory project))
(base (string-append project "-" version ".tar." archive-type)) (base (string-append project "-" version ".tar." archive-type))
(url (string-append "ftp://" server "/" directory "/" base)) (url (string-append "ftp://" server "/" directory "/" base))
(sig-url (string-append url ".sig")) (sig-url (string-append url ".sig"))
(tarball (download-to-store store url)) (tarball (download-to-store store url))
(sig (download-to-store store sig-url))) (sig (download-to-store store sig-url)))
(let ((ret (gnupg-verify* sig tarball))) (let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
(if ret (if ret
tarball tarball
(begin (begin
@ -359,9 +362,11 @@ success, return the tarball file name."
(warning (_ "(could be because the public key is not in your keyring)~%")) (warning (_ "(could be because the public key is not in your keyring)~%"))
#f))))) #f)))))
(define (package-update store package) (define* (package-update store package #:key (key-download 'interactive))
"Return the new version and the file name of the new version tarball for "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." 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) (match (package-update-path package)
((version . directory) ((version . directory)
(let-values (((name) (let-values (((name)
@ -372,7 +377,8 @@ PACKAGE, or #f and #f when PACKAGE is up-to-date."
(file-extension (origin-uri source))) (file-extension (origin-uri source)))
"gz")))) "gz"))))
(let ((tarball (download-tarball store name directory version (let ((tarball (download-tarball store name directory version
archive-type))) #:archive-type archive-type
#:key-download key-download)))
(values version tarball)))) (values version tarball))))
(_ (_
(values #f #f)))) (values #f #f))))

36
guix/gnupg.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -21,7 +22,9 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 i18n)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (guix ui)
#:export (%gpg-command #:export (%gpg-command
%openpgp-key-server %openpgp-key-server
gnupg-verify gnupg-verify
@ -145,16 +148,37 @@ missing key."
(define (gnupg-receive-keys key-id server) (define (gnupg-receive-keys key-id server)
(system* (%gpg-command) "--keyserver" server "--recv-keys" key-id)) (system* (%gpg-command) "--keyserver" server "--recv-keys" key-id))
(define* (gnupg-verify* sig file #:optional (server (%openpgp-key-server))) (define* (gnupg-verify* sig file
#:key (key-download 'interactive)
(server (%openpgp-key-server)))
"Like `gnupg-verify', but try downloading the public key if it's missing. "Like `gnupg-verify', but try downloading the public key if it's missing.
Return #t if the signature was good, #f otherwise." Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
and 'interactive' (default)."
(let ((status (gnupg-verify sig file))) (let ((status (gnupg-verify sig file)))
(or (gnupg-status-good-signature? status) (or (gnupg-status-good-signature? status)
(let ((missing (gnupg-status-missing-key? status))) (let ((missing (gnupg-status-missing-key? status)))
(define (download-and-try-again)
;; Download the missing key and try again.
(begin
(gnupg-receive-keys missing server)
(gnupg-status-good-signature? (gnupg-verify sig file))))
(define (receive?)
(let ((answer
(begin (format #t (_ "~a~a~%")
"Would you like to download this key "
"and add it to your keyring?")
(read-line))))
(string-match (locale-yes-regexp) answer)))
(and missing (and missing
(begin (case key-download
;; Download the missing key and try again. ((never) #f)
(gnupg-receive-keys missing server) ((always)
(gnupg-status-good-signature? (gnupg-verify sig file)))))))) (download-and-try-again))
(else
(and (receive?)
(download-and-try-again)))))))))
;;; gnupg.scm ends here ;;; gnupg.scm ends here

79
guix/scripts/refresh.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -64,6 +65,15 @@
(option '("gpg") #t #f (option '("gpg") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'gpg-command arg result))) (alist-cons 'gpg-command arg result)))
(option '("key-download") #t #f
(lambda (opt name arg result)
(match arg
((or "interactive" "always" "never")
(alist-cons 'key-download (string->symbol arg)
result))
(_
(leave (_ "unsupported policy: ~a~%")
arg)))))
(option '(#\h "help") #f #f (option '(#\h "help") #f #f
(lambda args (lambda args
@ -90,6 +100,11 @@ specified with `--select'.\n"))
--key-server=HOST use HOST as the OpenPGP key server")) --key-server=HOST use HOST as the OpenPGP key server"))
(display (_ " (display (_ "
--gpg=COMMAND use COMMAND as the GnuPG 2.x command")) --gpg=COMMAND use COMMAND as the GnuPG 2.x command"))
(display (_ "
--key-download=POLICY
handle missing OpenPGP keys according to POLICY:
'always', 'never', and 'interactive', which is also
used when 'key-download' is not specified"))
(newline) (newline)
(display (_ " (display (_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
@ -98,12 +113,14 @@ specified with `--select'.\n"))
(newline) (newline)
(show-bug-report-information)) (show-bug-report-information))
(define (update-package store package) (define* (update-package store package #:key (key-download 'interactive))
"Update the source file that defines PACKAGE with the new version." "Update the source file that defines PACKAGE with the new version.
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
values: 'interactive' (default), 'always', and 'never'."
(let-values (((version tarball) (let-values (((version tarball)
(catch #t (catch #t
(lambda () (lambda ()
(package-update store package)) (package-update store package #:key-download key-download))
(lambda _ (lambda _
(values #f #f)))) (values #f #f))))
((loc) ((loc)
@ -161,31 +178,33 @@ update would trigger a complete rebuild."
;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
(member (package-name package) names)))) (member (package-name package) names))))
(let* ((opts (parse-options)) (let* ((opts (parse-options))
(update? (assoc-ref opts 'update?)) (update? (assoc-ref opts 'update?))
(packages (match (concatenate (key-download (assoc-ref opts 'key-download))
(filter-map (match-lambda (packages
(('argument . value) (match (concatenate
(let ((p (find-packages-by-name value))) (filter-map (match-lambda
(unless p (('argument . value)
(leave (_ "~a: no package by that name") (let ((p (find-packages-by-name value)))
value)) (unless p
p)) (leave (_ "~a: no package by that name")
(_ #f)) value))
opts)) p))
(() ; default to all packages (_ #f))
(let ((select? (match (assoc-ref opts 'select) opts))
('core core-package?) (() ; default to all packages
('non-core (negate core-package?)) (let ((select? (match (assoc-ref opts 'select)
(_ (const #t))))) ('core core-package?)
;; TODO: Keep only the newest of each package. ('non-core (negate core-package?))
(fold-packages (lambda (package result) (_ (const #t)))))
(if (select? package) ;; TODO: Keep only the newest of each package.
(cons package result) (fold-packages (lambda (package result)
result)) (if (select? package)
'()))) (cons package result)
(some ; user-specified packages result))
some)))) '())))
(some ; user-specified packages
some))))
(with-error-handling (with-error-handling
(if update? (if update?
(let ((store (open-connection))) (let ((store (open-connection)))
@ -195,7 +214,9 @@ update would trigger a complete rebuild."
(%gpg-command (%gpg-command
(or (assoc-ref opts 'gpg-command) (or (assoc-ref opts 'gpg-command)
(%gpg-command)))) (%gpg-command))))
(for-each (cut update-package store <>) packages))) (for-each
(cut update-package store <> #:key-download key-download)
packages)))
(for-each (lambda (package) (for-each (lambda (package)
(match (false-if-exception (package-update-path package)) (match (false-if-exception (package-update-path package))
((new-version . directory) ((new-version . directory)