untar, untgz, and unzip: add #:permissive?

Also, strengthen the checking that `#:permissive?` (off by default)
performs for `untar` and `untgz` to disallow a link whose target is an
absolute path or has an up-directory element.

pkgs/racket-doc/file/scribblings/untar.scrbl

@@ -9,6 +9,7 @@ a function to extract items from a TAR/USTAR archive.}
 @defproc[(untar           [in (or/c path-string? input-port?)]
                           [#:dest dest-path (or/c path-string? #f) #f]
                           [#:strip-count strip-count exact-nonnegative-integer? 0]
+                          [#:permissive? permissive? any/c #f]
                           [#:filter filter-proc
                                     (path? (or/c path? #f)
                                      symbol? exact-integer? (or/c path? #f)
@@ -28,6 +29,12 @@ elements are removed from the item path from the archive (before
 prefixing the path with @racket[dest-path]); if the item's path
 contains @racket[strip-count] elements, then it is not extracted.
 
+Unless @racket[permissive?] is true, then archive items with paths containing
+an up-directory indicator are disallowed, and a link item whose target
+is an absolute path or contains an up-directory indicator is also
+disallowed. Absolute paths are always disallowed. A disallowed
+path triggers an exception.
+
 For each item in the archive, @racket[filter-proc] is applied to
 
 @itemlist[
@@ -60,4 +67,6 @@ For each item in the archive, @racket[filter-proc] is applied to
 ]
 
 If the result of @racket[filter-proc] is @racket[#f], then the item is
-not unpacked.}
+not unpacked.
+
+@history[#:changed "6.2.900.17" @elem{Added the @racket[#:permissive?] argument.}]}

pkgs/racket-doc/file/scribblings/untgz.scrbl

@@ -11,6 +11,7 @@ a function to extract items from a possible @exec{gzip}ped TAR/USTAR archive.}
 @defproc[(untgz           [in (or/c path-string? input-port?)]
                           [#:dest dest-path (or/c path-string? #f) #f]
                           [#:strip-count strip-count exact-nonnegative-integer? 0]
+                          [#:permissive? permissive? any/c #f]
                           [#:filter filter-proc
                                     (path? (or/c path? #f)
                                      symbol? exact-integer? (or/c path? #f)
@@ -21,4 +22,6 @@ a function to extract items from a possible @exec{gzip}ped TAR/USTAR archive.}
          void?]{
 
 The same as @racket[untar], but if @racket[in] is in @exec{gzip} form,
-it is @racket[gunzip]ped as it is unpacked.}
+it is @racket[gunzip]ped as it is unpacked.
+
+@history[#:changed "6.2.900.17" @elem{Added the @racket[#:permissive?] argument.}]}

pkgs/racket-doc/file/scribblings/unzip.scrbl

@@ -50,6 +50,7 @@ directory while returning the result of @racket[proc].
 @defproc[(make-filesystem-entry-reader
           [#:dest dest-path (or/c path-string? #f) #f]
           [#:strip-count strip-count exact-nonnegative-integer? 0]
+          [#:permissive? permissive? any/c #f]
           [#:exists exists (or/c 'skip 'error 'replace 'truncate 
                                  'truncate/replace 'append 'update
                                  'can-update 'must-truncate)
@@ -72,13 +73,21 @@ elements are removed from the entry path from the archive (before
 prefixing the path with @racket[dest-path]); if the item's path
 contains @racket[strip-count] elements, then it is not extracted.
 
+Unless @racket[permissive?] is true, then entries with paths containing
+an up-directory indicator are disallowed, and a link entry whose target
+is an absolute path or contains an up-directory indicator is also
+disallowed. Absolute paths are always disallowed. A disallowed
+path triggers an exception.
+
 If @racket[exists] is @racket['skip] and the file for an entry already
 exists, then the entry is skipped. Otherwise, @racket[exists] is
 passed on to @racket[open-output-file] for writing the entry's
 inflated content.
 
 @history[#:changed "6.0.0.3"
-         @elem{Added support for the optional timestamp argument in the result function.}]}
+         @elem{Added support for the optional timestamp argument in the result function.}
+         #:changed "6.2.900.17"
+         @elem{Added the @racket[#:permissive?] argument.}]}
 
 
 @defproc[(read-zip-directory [in (or/c path-string? input-port?)]) zip-directory?]{

pkgs/racket-test/tests/file/unpackers.rkt

@@ -98,7 +98,6 @@
   (delete-directory/files "sub")
   (file-or-directory-permissions* more-dir "rwx")
   
-  
   ;; make sure top-level file extraction works
   (untgz (open-input-bytes
           ;; bytes gotten from 'tar' and 'gzip' command-line tools
@@ -112,7 +111,28 @@
   (test (file-exists? "L1c"))
   (test (file-exists? "helper.rkt"))
   (delete-file "L1c")
-  (delete-file "helper.rkt"))
+  (delete-file "helper.rkt")
+
+  ;; check on [non-]permissive unpacking
+  (unless (eq? (system-type) 'windows)
+    (for ([target (in-list '("../x" "/tmp/abs" "ok"))])
+      (define ok? (equal? target "ok"))
+      (make-directory* "ex2")
+      (make-file-or-directory-link target (build-path "ex2" "link"))
+      (tar "ex2" a.tar)
+      (make-directory "sub")
+      (test (with-handlers ([exn:fail? (lambda (exn)
+                                         (regexp-match? #rx"up-directory|absolute" (exn-message exn)))])
+              (untar "a.tar" #:dest "sub")
+              ok?))
+      (test (equal? ok? (link-exists? (build-path "sub" "ex2" "link"))))
+      (delete-directory/files "sub")
+
+      (make-directory "sub")
+      (untar "a.tar" #:dest "sub" #:permissive? #t)
+      (test (link-exists? (build-path "sub" "ex2" "link")))
+      (delete-directory/files "sub")
+      (delete-directory/files "ex2"))))
 
 (define ((make-unzip-tests* preserve-timestamps?))
   (make-directory* "ex1")

racket/collects/file/private/check-path.rkt

@@ -2,10 +2,11 @@
 
 (provide check-unpack-path)
 
-(define (check-unpack-path who filename)
+(define (check-unpack-path who filename
+                           #:allow-up? [allow-up? #f])
   (when (absolute-path? filename)
     (error who "won't extract a file with an absolute path\n  path: ~e" filename))
+  (unless allow-up?
     (for ([e (in-list (explode-path filename))])
       (when (eq? e 'up)
-      (error who "won't extract a file with an up-directory element\n  path: ~e" filename))))
+        (error who "won't extract a file with an up-directory element\n  path: ~e" filename)))))
-

racket/collects/file/untar.rkt

@@ -11,6 +11,7 @@
               (#:dest 
                (or/c #f path-string?)
                #:strip-count exact-nonnegative-integer?
+               #:permissive? any/c
                #:filter (path? (or/c path? #f)
                                symbol? exact-integer? (or/c path? #f)
                                exact-nonnegative-integer? exact-nonnegative-integer?
@@ -22,6 +23,7 @@
 (define (untar in 
                #:dest [dest #f]
                #:strip-count [strip-count 0]
+               #:permissive? [permissive? #f]
                #:filter [filter void])
   ((if (input-port? in)
        (lambda (in f) (f in))
@@ -34,7 +36,8 @@
            (for ([delay (in-list (reverse delays))])
              (delay))
            (loop (untar-one-from-port in delays
-                                      dest strip-count filter)))))))
+                                      dest strip-count filter
+                                      permissive?)))))))
 
 (define (read-bytes* n in)
   (define s (read-bytes n in))
@@ -44,7 +47,8 @@
   s)
 
 (define (untar-one-from-port in delays
-                             dest strip-count filter)
+                             dest strip-count filter
+                             permissive?)
   (define name-bytes (read-bytes* 100 in))
   (define mode (tar-bytes->number (read-bytes* 8 in) in))
   (define owner (tar-bytes->number (read-bytes* 8 in) in))
@@ -79,7 +83,7 @@
                                      name
                                      (bytes-append prefix #"/" name)))
                                name))))
-  (check-unpack-path 'untar base-filename)
+  (check-unpack-path 'untar base-filename #:allow-up? permissive?)
   (define stripped-filename (strip-prefix base-filename strip-count))
   (define filename (and stripped-filename
                         (if dest
@@ -87,6 +91,8 @@
                             stripped-filename)))
   (define link-target (and (eq? type 'link)
                            (bytes->path (nul-terminated link-target-bytes))))
+  (when (and link-target (not permissive?))
+    (check-unpack-path 'untar link-target))
   (read-bytes* 12 in) ; padding
   (define create?
     (filter base-filename filename type size link-target mod-time mode))

racket/collects/file/untgz.rkt

@@ -11,6 +11,7 @@
               (#:dest 
                (or/c #f path-string?)
                #:strip-count exact-nonnegative-integer?
+               #:permissive? any/c
                #:filter (path? (or/c path? #f)
                                symbol? exact-integer? (or/c path? #f)
                                exact-nonnegative-integer? exact-nonnegative-integer?
@@ -20,6 +21,7 @@
 (define (untgz in 
                #:dest [dest #f]
                #:strip-count [strip-count 0]
+               #:permissive? [permissive? #f]
                #:filter [filter void])
   ((if (input-port? in)
        (lambda (in f) (f in))
@@ -44,7 +46,7 @@
                        (thread-wait t)))]
         [else (values in void)]))
      (begin0
-      (untar in2 #:dest dest #:strip-count strip-count #:filter filter)
+      (untar in2 #:dest dest #:strip-count strip-count #:permissive? permissive? #:filter filter)
       (wait)))))
 
       

racket/collects/file/unzip.rkt

@@ -25,6 +25,8 @@
                                      (or/c #f path-string?)
                                      #:strip-count
                                      exact-nonnegative-integer?
+                                     #:permissive?
+                                     any/c
                                      #:exists
                                      (or/c 'skip
                                            'error 'replace 'truncate 'truncate/replace 'append 'update
@@ -358,10 +360,10 @@
 
 ;; make-filesystem-entry-reader : [output-flag] -> (bytes boolean input-port -> any)
 (define make-filesystem-entry-reader
-  (lambda (#:dest [dest-dir #f] #:strip-count [strip-count 0] #:exists [flag 'error])
+  (lambda (#:dest [dest-dir #f] #:strip-count [strip-count 0] #:permissive? [permissive? #f] #:exists [flag 'error])
     (lambda (name dir? in [timestamp #f])
       (define path (bytes->path name))
-      (check-unpack-path 'unzip path)
+      (check-unpack-path 'unzip path #:allow-up? permissive?)
       (let* ([base-path (strip-prefix path strip-count)]
              [path (and base-path
                         (if dest-dir