From 814b099a209f335944737e701cbfcb09ac811d58 Mon Sep 17 00:00:00 2001
From: Tobias Geerinckx-Rice <me@tobias.gr>
Date: Wed, 25 Jan 2017 13:16:00 +0100
Subject: [PATCH] =?UTF-8?q?download:=20Add=20=E2=80=98url-fetch/zipbomb?=
 =?UTF-8?q?=E2=80=99.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

From this suggestion by Ludovic Courtès:
<http://lists.gnu.org/archive/html/guix-devel/2016-09/msg01983.html>

* guix/download.scm (url-fetch/zipbomb): New procedure.
---
 guix/download.scm | 30 ++++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)

diff --git a/guix/download.scm b/guix/download.scm
index e218c2e264..80efb9d9f1 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -36,6 +36,7 @@ (define-module (guix download)
   #:export (%mirrors
             url-fetch
             url-fetch/tarbomb
+            url-fetch/zipbomb
             download-to-store))
 
 ;;; Commentary:
@@ -512,6 +513,35 @@ (define tar
                                           "xf" #$drv)))
                       #:local-build? #t)))
 
+(define* (url-fetch/zipbomb url hash-algo hash
+                            #:optional name
+                            #:key (system (%current-system))
+                            (guile (default-guile)))
+  "Similar to 'url-fetch' but unpack the zip file at URL in a directory of its
+own.  This helper makes it easier to deal with \"zip bombs\"."
+  (define file-name
+    (match url
+      ((head _ ...)
+       (basename head))
+      (_
+       (basename url))))
+  (define unzip
+    (module-ref (resolve-interface '(gnu packages zip)) 'unzip))
+
+  (mlet %store-monad ((drv (url-fetch url hash-algo hash
+                                      (string-append "zipbomb-"
+                                                     (or name file-name))
+                                      #:system system
+                                      #:guile guile)))
+    ;; Take the zip bomb, and simply unpack it as a directory.
+    (gexp->derivation (or name file-name)
+                      #~(begin
+                          (mkdir #$output)
+                          (chdir #$output)
+                          (zero? (system* (string-append #$unzip "/bin/unzip")
+                                          #$drv)))
+                      #:local-build? #t)))
+
 (define* (download-to-store store url #:optional (name (basename url))
                             #:key (log (current-error-port)) recursive?
                             (verify-certificate? #t))