diff options
| -rw-r--r-- | guix/gnu-maintenance.scm | 18 | ||||
| -rw-r--r-- | guix/gnupg.scm | 36 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 79 |
3 files changed, 92 insertions, 41 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index b54cd84ecf..b460976f4e 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -341,16 +341,19 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (_ #f)))) (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 -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)) (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))) + (let ((ret (gnupg-verify* sig tarball #:key-download key-download))) (if ret tarball (begin @@ -359,9 +362,11 @@ success, return the tarball file name." (warning (_ "(could be because the public key is not in your keyring)~%")) #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 -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) ((version . directory) (let-values (((name) @@ -372,7 +377,8 @@ PACKAGE, or #f and #f when PACKAGE is up-to-date." (file-extension (origin-uri source))) "gz")))) (let ((tarball (download-tarball store name directory version - archive-type))) + #:archive-type archive-type + #:key-download key-download))) (values version tarball)))) (_ (values #f #f)))) diff --git a/guix/gnupg.scm b/guix/gnupg.scm index c17a495f81..29ddc78e27 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +22,9 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:use-module (ice-9 i18n) #:use-module (srfi srfi-1) + #:use-module (guix ui) #:export (%gpg-command %openpgp-key-server gnupg-verify @@ -145,16 +148,37 @@ missing key." (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))) +(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. -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))) (or (gnupg-status-good-signature? 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 - (begin - ;; Download the missing key and try again. - (gnupg-receive-keys missing server) - (gnupg-status-good-signature? (gnupg-verify sig file)))))))) + (case key-download + ((never) #f) + ((always) + (download-and-try-again)) + (else + (and (receive?) + (download-and-try-again))))))))) ;;; gnupg.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 10715ebc2d..b8d4efd204 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -64,6 +65,15 @@ (option '("gpg") #t #f (lambda (opt name 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 (lambda args @@ -90,6 +100,11 @@ specified with `--select'.\n")) --key-server=HOST use HOST as the OpenPGP key server")) (display (_ " --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) (display (_ " -h, --help display this help and exit")) @@ -98,12 +113,14 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) -(define (update-package store package) - "Update the source file that defines PACKAGE with the new version." +(define* (update-package store package #:key (key-download 'interactive)) + "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) (catch #t (lambda () - (package-update store package)) + (package-update store package #:key-download key-download)) (lambda _ (values #f #f)))) ((loc) @@ -161,31 +178,33 @@ update would trigger a complete rebuild." ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. (member (package-name package) names)))) - (let* ((opts (parse-options)) - (update? (assoc-ref opts 'update?)) - (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 - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - ;; TODO: Keep only the newest of each package. - (fold-packages (lambda (package result) - (if (select? package) - (cons package result) - result)) - '()))) - (some ; user-specified packages - some)))) + (let* ((opts (parse-options)) + (update? (assoc-ref opts 'update?)) + (key-download (assoc-ref opts 'key-download)) + (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 + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + ;; TODO: Keep only the newest of each package. + (fold-packages (lambda (package result) + (if (select? package) + (cons package result) + result)) + '()))) + (some ; user-specified packages + some)))) (with-error-handling (if update? (let ((store (open-connection))) @@ -195,7 +214,9 @@ update would trigger a complete rebuild." (%gpg-command (or (assoc-ref opts '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) (match (false-if-exception (package-update-path package)) ((new-version . directory) |