diff options
| author | Tobias Geerinckx-Rice <me@tobias.gr> | 2017-01-25 13:16:00 +0100 |
|---|---|---|
| committer | Tobias Geerinckx-Rice <me@tobias.gr> | 2017-02-01 15:53:33 +0100 |
| commit | 814b099a209f335944737e701cbfcb09ac811d58 (patch) | |
| tree | 3ee3adebc6b35ab1fda1a892b78f8617aa453c0a | |
| parent | 58f91e4d03e102058fc0f8a859cb144c40c6a1d0 (diff) | |
| download | guix-814b099a209f335944737e701cbfcb09ac811d58.tar guix-814b099a209f335944737e701cbfcb09ac811d58.tar.gz | |
download: Add ‘url-fetch/zipbomb’.
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.
| -rw-r--r-- | guix/download.scm | 30 |
1 files changed, 30 insertions, 0 deletions
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 @@ #: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)) |