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

[ng0 <contact.ng0@cryptolab.net>]

Tobias Geerinckx-Rice <me@tobias.gr> writes:

> 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
>
>

Looks good to me at first, on functionality side I can atest that
the zpaq build succeeds with this.
-- 
♥Ⓐ  ng0 -- https://www.inventati.org/patternsinthechaos/