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

Detect and propagate errors from tar to result of tar-gzip.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2016-12-20 13:47:47 +13:00
parent 3e4a0353cf
commit b99639ff97
2 changed files with 33 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/racket-test/tests/file/gzip.rkt
View File

@ -77,6 +77,26 @@
;; should be around 6 times smaller
(id* (file->bytes big-file) 4))
(define (test-hang-on-long-filename)
;; `tar-gzip` was crashing in a background thread due to a very long
;; filename, leading to a hang in the main thread. Trigger the bug
;; with a long filename, and check that progress is made in a
;; reasonable length of time.
(local-require file/tar)
(define long-filename
"extremely-long-file-name-that-exceeds-the-internal-length-limits-on-USTAR-because-of-arcane-decisions-and-bad-choices-of-fixed-width-records-and-so-on-and-so-on")
(define temp-dir (find-system-path 'temp-dir))
(define long-path (build-path temp-dir long-filename))
(with-output-to-file long-path (lambda () (write long-filename)) #:exists 'replace)
(define tgz-file (build-path temp-dir "long-filename-test.tgz"))
(when (file-exists? tgz-file) (delete-file tgz-file))
(define ch (make-channel))
(thread (lambda ()
(with-handlers [(exn:fail? (lambda (_exn) (channel-put ch 'success)))]
(tar-gzip tgz-file long-path)
(channel-put ch 'didnt-fail-in-tar-gzip))))
(test (sync/timeout 10 ch) => 'success))
(define (run-tests)
(define (rand-bytes)
(list->bytes (for/list ([j (in-range (random 1000))]) (random 256))))
@ -84,7 +104,8 @@
(test-degenerate-input-1)
(test-degenerate-input-2)
(for ([i (in-range 100)]) (id* (rand-bytes)))
(regression-test))
(regression-test)
(test-hang-on-long-filename))
(define (regression-test)
;; check for an out-of-range buffer access:

19
racket/collects/file/tar.rkt
View File

@ -180,14 +180,16 @@
#:exists (if exists-ok? 'truncate/replace 'error)
(lambda ()
(let-values ([(i o) (make-pipe (* 1024 1024 32))])
(define tar-exn #f)
(thread (lambda ()
(tar->output (pathlist-closure paths
#:follow-links? follow-links?
#:path-filter path-filter)
o
#:path-prefix prefix
#:follow-links? follow-links?
#:get-timestamp get-timestamp)
(with-handlers [((lambda (exn) #t) (lambda (exn) (set! tar-exn exn)))]
(tar->output (pathlist-closure paths
#:follow-links? follow-links?
#:path-filter path-filter)
o
#:path-prefix prefix
#:follow-links? follow-links?
#:get-timestamp get-timestamp))
(close-output-port o)))
(gzip-through-ports
i (current-output-port)
@ -196,4 +198,5 @@
(path->string tgz-file) tgz-file))
=> (lambda (m) (string-append (car m) "tar"))]
[else #f])
(current-seconds))))))
(current-seconds))
(when tar-exn (raise tar-exn))))))