upstream: Properly verify signatures of uncompressed tarballs.
* guix/upstream.scm (uncompressed-tarball): New procedure. (download-tarball): Use it when the basename of SIGNATURE-URL doesn't contain the basename of URL.
This commit is contained in:
parent
4e6230ec00
commit
8d5d06282e
|
@ -26,6 +26,11 @@
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (guix ui)
|
#:use-module (guix ui)
|
||||||
#:use-module (guix base32)
|
#:use-module (guix base32)
|
||||||
|
#:use-module (guix gexp)
|
||||||
|
#:use-module (guix store)
|
||||||
|
#:use-module ((guix derivations)
|
||||||
|
#:select (built-derivations derivation->output-path))
|
||||||
|
#:use-module (guix monads)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
|
@ -149,6 +154,32 @@ than that of PACKAGE."
|
||||||
(_
|
(_
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
|
(define (uncompressed-tarball name tarball)
|
||||||
|
"Return a derivation that decompresses TARBALL."
|
||||||
|
(define (ref package)
|
||||||
|
(module-ref (resolve-interface '(gnu packages compression))
|
||||||
|
package))
|
||||||
|
|
||||||
|
(define compressor
|
||||||
|
(cond ((or (string-suffix? ".gz" tarball)
|
||||||
|
(string-suffix? ".tgz" tarball))
|
||||||
|
(file-append (ref 'gzip) "/bin/gzip"))
|
||||||
|
((string-suffix? ".bz2" tarball)
|
||||||
|
(file-append (ref 'bzip2) "/bin/bzip2"))
|
||||||
|
((string-suffix? ".xz" tarball)
|
||||||
|
(file-append (ref 'xz) "/bin/xz"))
|
||||||
|
((string-suffix? ".lz" tarball)
|
||||||
|
(file-append (ref 'lzip) "/bin/lzip"))
|
||||||
|
(else
|
||||||
|
(error "unknown archive type" tarball))))
|
||||||
|
|
||||||
|
(gexp->derivation (file-sans-extension name)
|
||||||
|
#~(begin
|
||||||
|
(copy-file #+tarball #+name)
|
||||||
|
(and (zero? (system* #+compressor "-d" #+name))
|
||||||
|
(copy-file #+(file-sans-extension name)
|
||||||
|
#$output)))))
|
||||||
|
|
||||||
(define* (download-tarball store url signature-url
|
(define* (download-tarball store url signature-url
|
||||||
#:key (key-download 'interactive))
|
#:key (key-download 'interactive))
|
||||||
"Download the tarball at URL to the store; check its OpenPGP signature at
|
"Download the tarball at URL to the store; check its OpenPGP signature at
|
||||||
|
@ -160,7 +191,21 @@ values: 'interactive' (default), 'always', and 'never'."
|
||||||
(if (not signature-url)
|
(if (not signature-url)
|
||||||
tarball
|
tarball
|
||||||
(let* ((sig (download-to-store store signature-url))
|
(let* ((sig (download-to-store store signature-url))
|
||||||
(ret (gnupg-verify* sig tarball #:key-download key-download)))
|
|
||||||
|
;; Sometimes we get a signature over the uncompressed tarball.
|
||||||
|
;; In that case, decompress the tarball in the store so that we
|
||||||
|
;; can check the signature.
|
||||||
|
(data (if (string-prefix? (basename url)
|
||||||
|
(basename signature-url))
|
||||||
|
tarball
|
||||||
|
(run-with-store store
|
||||||
|
(mlet %store-monad ((drv (uncompressed-tarball
|
||||||
|
(basename url) tarball)))
|
||||||
|
(mbegin %store-monad
|
||||||
|
(built-derivations (list drv))
|
||||||
|
(return (derivation->output-path drv)))))))
|
||||||
|
|
||||||
|
(ret (gnupg-verify* sig data #:key-download key-download)))
|
||||||
(if ret
|
(if ret
|
||||||
tarball
|
tarball
|
||||||
(begin
|
(begin
|
||||||
|
|
Loading…
Reference in New Issue