04/08: upstream: Properly verify signatures of uncompressed tarballs.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 8d5d06282e255557d3bdda1794bd3fea2c84ff59
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 30 17:30:12 2016 +0100

    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.
---
 guix/upstream.scm |   49 +++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 47 insertions(+), 2 deletions(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index 08992dc..8685afd 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -26,6 +26,11 @@
   #:use-module (guix packages)
   #:use-module (guix ui)
   #: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-9)
   #:use-module (srfi srfi-11)
@@ -149,6 +154,32 @@ than that of PACKAGE."
     (_
      #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
                            #:key (key-download 'interactive))
   "Download the tarball at URL to the store; check its OpenPGP signature at
@@ -159,8 +190,22 @@ values: 'interactive' (default), 'always', and 'never'."
   (let ((tarball (download-to-store store url)))
     (if (not signature-url)
         tarball
-        (let* ((sig (download-to-store store signature-url))
-               (ret (gnupg-verify* sig tarball #:key-download key-download)))
+        (let* ((sig  (download-to-store store signature-url))
+
+               ;; 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
               tarball
               (begin