Re: New “guix refresh” command

[Nikita Karetnikov <nikita@karetnikov.org>]

[-- Attachment #1.1: Type: text/plain, Size: 1731 bytes --]

> That could be done by changing ‘gnupg-verify*’.  An optional argument
> could be added to select between interactive behavior (“do you want to
> download this key and add it to your keyring?”), always-download, and
> never-download.

I'm attaching my attempt.

There are two similar but unrelated problems:

1. The following function 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))

2. 'else' doesn't work.

(else
 (and (receive?)
	  (download-and-try-again)))

# which gpg2
/root/.guix-profile/bin/gpg2
# gpg2 --delete-key EA52ECF4
# ./pre-inst-env guix refresh -u
accepted connection from pid 7779, uid 0
starting download of `guix-file.RAA3r7' from `ftp://ftp.gnu.org//gnu/guile/guile-2.0.9.tar.gz'...
ftp://ftp.gnu.org/.../guile-2.0.9.tar.gz	100.0% of 7163.4 KiB
starting download of `guix-file.gJlE96' from `ftp://ftp.gnu.org//gnu/guile/guile-2.0.9.tar.gz.sig'...
ftp://ftp.gnu.org/.../guile-2.0.9.tar.gz.sig	100.0% of 0.2 KiB
gpg: Signature made Wed 10 Apr 2013 06:14:45 AM UTC using DSA key ID EA52ECF4
gpg: Can't check signature: No public key

(It should print the above message here, but it always tries to download
GCC instead.)

starting download of `guix-file.ZkDiI7' from `ftp://ftp.gnu.org//gnu/gcc/gcc-4.8.0/gcc-4.8.0.tar.bz2'...

To-do list:

1. Any argument except 'always', 'never', and 'interactive' should raise
   an error.

2. Fetch signatures first and don't download tarballs which can't be
   authenticated (when signatures are missing and 'never' is used).

3. How should I change 'receive?' to support i18n?

Anything else?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: download-sigs.diff --]
[-- Type: text/x-diff, Size: 11004 bytes --]

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 <http://www.gnu.org/licenses/>.
 
 (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)

[-- Attachment #2: Type: application/pgp-signature, Size: 835 bytes --]