From 8d5d06282e255557d3bdda1794bd3fea2c84ff59 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 30 Nov 2016 17:30:12 +0100
Subject: [PATCH] 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 08992dc19e..8685afd860 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -26,6 +26,11 @@ (define-module (guix upstream)
   #: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 @@ (define (package-latest-release* package updaters)
     (_
      #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 @@ (define* (download-tarball store url signature-url
   (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