suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

untar and unzip: reject paths that contain ".."

Browse Source 
Also, for unzip, reject absolute paths.
This commit is contained in:
Matthew Flatt 2015-09-02 13:15:03 -06:00
parent efe056f18d
commit 322714f123
3 changed files with 19 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
racket/collects/file/private/check-path.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(provide check-unpack-path)
(define (check-unpack-path who filename)
(when (absolute-path? filename)
(error who "won't extract a file with an absolute path\n path: ~e" filename))
(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))))

6
racket/collects/file/untar.rkt
View File

@ -2,7 +2,8 @@
(require racket/file
racket/contract/base
racket/port
"private/strip-prefix.rkt")
"private/strip-prefix.rkt"
"private/check-path.rkt")
(provide
(contract-out
@ -78,8 +79,7 @@
name
(bytes-append prefix #"/" name)))
name))))
(when (absolute-path? base-filename)
(error 'untar "won't extract a file with an absolute path: ~e" base-filename))
(check-unpack-path 'untar base-filename)
(define stripped-filename (strip-prefix base-filename strip-count))
(define filename (and stripped-filename
(if dest

7
racket/collects/file/unzip.rkt
View File

@ -4,7 +4,8 @@
racket/file
racket/date
file/gunzip
"private/strip-prefix.rkt")
"private/strip-prefix.rkt"
"private/check-path.rkt")
(provide
(struct-out exn:fail:unzip:no-such-entry)
@ -359,7 +360,9 @@
(define make-filesystem-entry-reader
(lambda (#:dest [dest-dir #f] #:strip-count [strip-count 0] #:exists [flag 'error])
(lambda (name dir? in [timestamp #f])
(let* ([base-path (strip-prefix (bytes->path name) strip-count)]
(define path (bytes->path name))
(check-unpack-path 'unzip path)
(let* ([base-path (strip-prefix path strip-count)]
[path (and base-path
(if dest-dir
(build-path dest-dir base-path)