diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index b54cd84..04d72d3 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 optargs) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -341,7 +342,7 @@ 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")) + #:optional (archive-type "gz") download-sigs) "Download PROJECT's tarball over FTP and check its OpenPGP signature. On success, return the tarball file name." (let* ((server (ftp-server/directory project)) @@ -350,7 +351,7 @@ success, return the tarball file name." (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 download-sigs))) (if ret tarball (begin @@ -359,7 +360,7 @@ 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 #:optional download-sigs) "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) @@ -372,7 +373,7 @@ 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 download-sigs))) (values version tarball)))) (_ (values #f #f)))) diff --git a/guix/gnupg.scm b/guix/gnupg.scm index c17a495..8d2a7e6 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix gnupg) + #:use-module (ice-9 format) #:use-module (ice-9 popen) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -145,16 +146,42 @@ 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 #:optional download-sigs + (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)))))))) + (define (download-and-try-again) + (begin + ;; Download the missing key and try again. + (gnupg-receive-keys missing server) + (gnupg-status-good-signature? (gnupg-verify sig file)))) + + (define (receive?) + (string=? "y" ; XXX: i18n + + ;; XXX: Doesn't print the message. + ;; (begin (format #t (_ "~a~a~!") + ;; "Would you like to download this key " + ;; "and add it to your keyring? (y/N) ") + ;; (read-line)))) + + (begin (format #t "~a~a~!" + "Would you like to download this key " + "and add it to your keyring? (y/N) ") + (read-line)))) + + (and + missing + ;; XXX: 'else' doesn't work. + (cond ((string=? download-sigs "always") + (download-and-try-again)) + ((string=? download-sigs "never") + #f) + (else + (and (receive?) + (download-and-try-again))))))))) ;;; gnupg.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 10715eb..9beeddc 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -27,6 +27,7 @@ #:use-module ((gnu packages base) #:select (%final-inputs)) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 optargs) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -64,6 +65,9 @@ (option '("gpg") #t #f (lambda (opt name arg result) (alist-cons 'gpg-command arg result))) + (option '(#\d "download-sigs") #t #f + (lambda (opt name arg result) + (alist-cons 'download-sigs arg result))) (option '(#\h "help") #f #f (lambda args @@ -79,7 +83,11 @@ Update package definitions to match the latest upstream version. When PACKAGE... is given, update only the specified packages. Otherwise update all the packages of the distribution, or the subset thereof -specified with `--select'.\n")) +specified with `--select'. + +'download-sigs' accepts one of the following arguments: 'interactive', +'always', and 'never'. When 'download-sigs' is not specified, assume +'interactive'.\n")) (display (_ " -u, --update update source files in place")) (display (_ " @@ -90,6 +98,9 @@ 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 (_ " + -d, --download-sigs=ARG + download and add signatures to your keyring")) (newline) (display (_ " -h, --help display this help and exit")) @@ -98,12 +109,12 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) -(define (update-package store package) +(define* (update-package store package #:optional download-sigs) "Update the source file that defines PACKAGE with the new version." (let-values (((version tarball) (catch #t (lambda () - (package-update store package)) + (package-update store package download-sigs)) (lambda _ (values #f #f)))) ((loc) @@ -161,31 +172,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?)) + (download-sigs (assoc-ref opts 'download-sigs)) + (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 +208,7 @@ 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 <> download-sigs) packages))) (for-each (lambda (package) (match (false-if-exception (package-update-path package)) ((new-version . directory)