[PATCH 2/3] download: Add ‘url-fetch/zipbomb’.

[Tobias Geerinckx-Rice]

>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 e218c2e..80efb9d 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -36,6 +36,7 @@
   #:export (%mirrors
             url-fetch
             url-fetch/tarbomb
+            url-fetch/zipbomb
             download-to-store))
 
 ;;; Commentary:
@@ -512,6 +513,35 @@ own.  This helper makes it easier to deal with \"tar 
bombs\"."
                                           "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))
-- 
2.9.3