mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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
parent
e20ec9cc51
commit
392b5d8cab
3 changed files with 92 additions and 41 deletions
|
|
@ -341,16 +341,19 @@ (define (package-update-path package)
|
|||
(_ #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 @@ (define* (download-tarball store project directory version
|
|||
(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 @@ (define (package-update store package)
|
|||
(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))))
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-module (guix gnupg)
|
|||
#: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 @@ (define (gnupg-status-missing-key? 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)))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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 @@ (define %options
|
|||
(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 @@ (define (show-help)
|
|||
--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 @@ (define (show-help)
|
|||
(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 @@ (define core-package?
|
|||
;; 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 @@ (define core-package?
|
|||
(%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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue