ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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 @@ (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))))

34
guix/gnupg.scm
View file

@ -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)))
(and missing
(begin
(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))))))))
(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
(case key-download
((never) #f)
((always)
(download-and-try-again))
(else
(and (receive?)
(download-and-try-again)))))))))
;;; gnupg.scm ends here

31
guix/scripts/refresh.scm
View file

@ -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)
@ -163,7 +180,9 @@ (define core-package?
(let* ((opts (parse-options))
(update? (assoc-ref opts 'update?))
(packages (match (concatenate
(key-download (assoc-ref opts 'key-download))
(packages
(match (concatenate
(filter-map (match-lambda
(('argument . value)
(let ((p (find-packages-by-name value)))
@ -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)