From 95001d4b4677b64f26a4bf202a77267830bb7039 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 22 Feb 2016 00:29:54 +0100
Subject: download: Add 'url-fetch/tarbomb'.

Suggested by Federico Beffa.
Fixes <http://bugs.gnu.org/22676>.
Reported by Danny Milosavljevic <dannym@scratchpost.org>.

* gnu/packages/engineering.scm (broken-tarball-fetch): Remove.
(fastcap)[source](method): Use URL-FETCH/TARBOMB instead.
* gnu/packages/scheme.scm (broken-tarball-fetch): Remove.
(scmutils)[source](method): Use URL-FETCH/TARBOMB instead.
* guix/download.scm (url-fetch/tarbomb): New procedure, renamed from
'broken-tarball-fetch'.
---
 gnu/packages/engineering.scm | 21 +--------------------
 gnu/packages/scheme.scm      |  8 +-------
 guix/download.scm            | 29 ++++++++++++++++++++++++++++-
 3 files changed, 30 insertions(+), 28 deletions(-)

diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm
index 204ea9dc02..9a36ffbb31 100644
--- a/gnu/packages/engineering.scm
+++ b/gnu/packages/engineering.scm
@@ -203,31 +203,12 @@ and design rule checking.  It also includes an autorouter and a trace
 optimizer; and it can produce photorealistic and design review images.")
     (license license:gpl2+)))
 
-(define* (broken-tarball-fetch url hash-algo hash
-                               #:optional name
-                               #:key (system (%current-system))
-                               (guile (default-guile)))
-  (mlet %store-monad ((drv (url-fetch url hash-algo hash
-                                      (string-append "tarbomb-" name)
-                                      #:system system
-                                      #:guile guile)))
-    ;; Take the tar bomb, and simply unpack it as a directory.
-    (gexp->derivation name
-                      #~(begin
-                          (mkdir #$output)
-                          (setenv "PATH"
-                                  (string-append #$gzip "/bin"))
-                          (chdir #$output)
-                          (zero? (system* (string-append #$tar "/bin/tar")
-                                          "xf" #$drv))))))
-
-
 (define-public fastcap
   (package
     (name "fastcap")
     (version "2.0-18Sep92")
     (source (origin
-              (method broken-tarball-fetch)
+              (method url-fetch/tarbomb)
               (file-name (string-append name "-" version ".tar.gz"))
               (uri (string-append "http://www.rle.mit.edu/cpg/codes/"
                                   name "-" version ".tgz"))
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 352b66c59b..00b573fc0b 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -526,12 +526,6 @@ an isolated heap allowing multiple VMs to run simultaneously in different OS
 threads.")
     (license bsd-3)))
 
-;; FIXME: This function is temporarily in the engineering module and not
-;; exported.  It will be moved to an utility module for general use.  Once
-;; this is done, we should remove this definition.
-(define broken-tarball-fetch
-  (@@ (gnu packages engineering) broken-tarball-fetch))
-
 (define-public scmutils
   (let ()
     (define (system-suffix)
@@ -546,7 +540,7 @@ threads.")
       (version "20140302")
       (source
        (origin
-         (method broken-tarball-fetch)
+         (method url-fetch/tarbomb)
          (modules '((guix build utils)))
          (snippet
           ;; Remove binary code
diff --git a/guix/download.scm b/guix/download.scm
index 204cfc0826..88f285dc0a 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,6 +32,7 @@
   #:use-module (srfi srfi-26)
   #:export (%mirrors
             url-fetch
+            url-fetch/tarbomb
             download-to-store))
 
 ;;; Commentary:
@@ -294,6 +296,31 @@ in the store."
                             ;; <https://bugs.gnu.org/18747>.)
                             #:local-build? #t)))))
 
+(define* (url-fetch/tarbomb url hash-algo hash
+                            #:optional name
+                            #:key (system (%current-system))
+                            (guile (default-guile)))
+  "Similar to 'url-fetch' but unpack the file from URL in a directory of its
+own.  This helper makes it easier to deal with \"tar bombs\"."
+  (define gzip
+    (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
+  (define tar
+    (module-ref (resolve-interface '(gnu packages base)) 'tar))
+
+  (mlet %store-monad ((drv (url-fetch url hash-algo hash
+                                      (string-append "tarbomb-" name)
+                                      #:system system
+                                      #:guile guile)))
+    ;; Take the tar bomb, and simply unpack it as a directory.
+    (gexp->derivation name
+                      #~(begin
+                          (mkdir #$output)
+                          (setenv "PATH" (string-append #$gzip "/bin"))
+                          (chdir #$output)
+                          (zero? (system* (string-append #$tar "/bin/tar")
+                                          "xf" #$drv)))
+                      #:local-build? #t)))
+
 (define* (download-to-store store url #:optional (name (basename url))
                             #:key (log (current-error-port)) recursive?)
   "Download from URL to STORE, either under NAME or URL's basename if
-- 
cgit v1.2.3