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'.
---
 guix/download.scm | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

(limited to 'guix')

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 @@ (define-module (guix download)
   #:use-module (srfi srfi-26)
   #:export (%mirrors
             url-fetch
+            url-fetch/tarbomb
             download-to-store))
 
 ;;; Commentary:
@@ -294,6 +296,31 @@ (define builder
                             ;; <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