mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 13:58:15 -05:00
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.
This commit is contained in:
parent
58f91e4d03
commit
814b099a20
1 changed files with 30 additions and 0 deletions
|
@ -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))
|
||||
|
|
Loading…
Reference in a new issue