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

avoid using directory-exists? as part of a contract

Browse Source 
Although a `directory-exists?` check is useful for providing better
error messages, it's fundentally a race condition, since an external
process can always remove a directory between the check and a use of
the directory. Because of that limitation of `directory-exists?`, we
normally avoid making it part of a contract. This commit adjust
937aa3cdb1 to follow that convention while preserving the helpful
check and documentation improvements.
This commit is contained in:
Matthew Flatt 2018-10-10 06:25:09 -06:00
parent 6c0d193132
commit 2b9c0c4689
3 changed files with 41 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-doc/pkg/scribblings/strip.scrbl
View File

@ -215,21 +215,23 @@ with the same file/directory omissions and updates as
@command-ref{create}.} @command-ref{create}.}
@defproc[(generate-stripped-directory [mode (or/c 'source 'binary 'binary-lib 'built)] @defproc[(generate-stripped-directory [mode (or/c 'source 'binary 'binary-lib 'built)]
[src-dir (and/c path-string? directory-exists?)] [src-dir path-string?]
[dest-dir (and/c path-string? directory-exists?)]) [dest-dir path-string?])
void?]{ void?]{
Copies @racket[src-dir] to @racket[dest-dir] with file/directory Copies @racket[src-dir] to @racket[dest-dir] with file/directory
omissions and updates corresponding to the creation of a @tech{source omissions and updates corresponding to the creation of a @tech{source
package}, @tech{binary package}, @tech{binary library package}, or @tech{built package} as indicated package}, @tech{binary package}, @tech{binary library package}, or @tech{built package} as indicated
by @racket[mode].} Note, @racket[generate-stripped-directory] does not compile or render source files by @racket[mode]. The given @racket[src-dir] and @racket[dest-dir] must both exist already.
Note that @racket[generate-stripped-directory] does not compile or render source files
found in the @racket[src-dir]. To perform precompilation or rendering before stripping the source directory, found in the @racket[src-dir]. To perform precompilation or rendering before stripping the source directory,
use @exec{raco setup} or @exec{raco make}. use @exec{raco setup} or @exec{raco make}.}
@defproc[(check-strip-compatible [mode (or/c 'source 'binary 'binary-lib 'built)] @defproc[(check-strip-compatible [mode (or/c 'source 'binary 'binary-lib 'built)]
[pkg-name string?] [pkg-name string?]
[dir (and/c path-string? directory-exists?)] [dir path-string?]
[error (string? . -> . any)]) [error (string? . -> . any)])
any]{ any]{

26
pkgs/racket-test/tests/pkg/tests-api.rkt
View File

@ -14,35 +14,37 @@
(define pkg-dest-path (build-path tmp-dir "pkg-strip")) (define pkg-dest-path (build-path tmp-dir "pkg-strip"))
(make-directory pkg-dest-path) (make-directory pkg-dest-path)
(define rx:does-not-exist #rx"directory does not exist")
;; Giving path to nonexistent directory should raise a contract exception. ;; Giving path to nonexistent directory should raise a contract exception.
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'source "pkg-strip" "does not exist" error))) (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'source "pkg-strip" "does not exist" error)))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'binary "pkg-strip" "does not exist" error))) (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'binary "pkg-strip" "does not exist" error)))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'binary-lib "pkg-strip" "does not exist" error))) (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'binary-lib "pkg-strip" "does not exist" error)))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'built "pkg-strip" "does not exist" error))) (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'built "pkg-strip" "does not exist" error)))
;; Path to existing directory should succeed. ;; Path to existing directory should succeed.
(check-not-exn (lambda () (check-strip-compatible 'source "pkg-strip" pkg-path error))) (check-not-exn (lambda () (check-strip-compatible 'source "pkg-strip" pkg-path error)))
;; Giving path to nonexistent src directory should raise a contract exception. ;; Giving path to nonexistent src directory should raise a contract exception.
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'source 5 pkg-dest-path))) (check-exn exn:fail:contract? (lambda () (generate-stripped-directory 'source 5 pkg-dest-path)))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary "does not exist" pkg-dest-path))) (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary "does not exist" pkg-dest-path)))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary-lib "does not exist" pkg-dest-path))) (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary-lib "does not exist" pkg-dest-path)))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'built "does not exist" pkg-dest-path))) (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'built "does not exist" pkg-dest-path)))
;; Giving path to nonexistent dest directory should raise a contract exception. ;; Giving path to nonexistent dest directory should raise a contract exception.
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'source pkg-path "does not exist"))) (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'source pkg-path "does not exist")))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary pkg-path "does not exist"))) (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary pkg-path "does not exist")))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary-lib pkg-path "does not exist"))) (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary-lib pkg-path "does not exist")))
(check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'built pkg-path "does not exist"))) (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'built pkg-path "does not exist")))
;; Paths to existing src and dest directories should succeed. ;; Paths to existing src and dest directories should succeed.
(check-not-exn (lambda () (generate-stripped-directory 'source pkg-path pkg-dest-path))) (check-not-exn (lambda () (generate-stripped-directory 'source pkg-path pkg-dest-path)))

36
racket/collects/pkg/strip.rkt
View File

@ -21,11 +21,9 @@
(define strip-binary-compile-info (make-parameter #t)) (define strip-binary-compile-info (make-parameter #t))
(define (check-strip-compatible mode pkg dir error) (define (check-strip-compatible mode pkg dir error)
(unless (and (path-string? dir) (directory-exists? dir)) (unless (path-string? dir)
(raise-argument-error (raise-argument-error 'check-strip-compatible "path-string?" dir))
'check-strip-compatible (check-directory-exists 'check-strip-compatible "" dir)
"(and/c path-string? directory-exists?)"
dir))
(define i (get-info/full dir)) (define i (get-info/full dir))
(define raw-status (and i (define raw-status (and i
@ -64,17 +62,12 @@
(define (generate-stripped-directory mode dir dest-dir (define (generate-stripped-directory mode dir dest-dir
#:check-status? [check-status? #t]) #:check-status? [check-status? #t])
(unless (and (path-string? dir) (directory-exists? dir)) (unless (path-string? dir)
(raise-argument-error (raise-argument-error 'generate-stripped-directory "path-string?" dir))
'generate-stripped-directory (unless (path-string? dest-dir)
"(and/c path-string? directory-exists?)" (raise-argument-error 'generate-stripped-directory "path-string?" dest-dir))
dir)) (check-directory-exists 'generate-stripped-directory "source " dir)
(check-directory-exists 'generate-stripped-directory "destination " dest-dir)
(unless (and (path-string? dest-dir) (directory-exists? dest-dir))
(raise-argument-error
'generate-stripped-directory
"(and/c path-string? directory-exists?)"
dest-dir))
(define drop-keep-ns (make-base-namespace)) (define drop-keep-ns (make-base-namespace))
(define (add-drop+keeps dir base drops keeps) (define (add-drop+keeps dir base drops keeps)
@ -487,3 +480,14 @@
(for ([f (in-list (directory-list dest-dir #:build? #t))]) (for ([f (in-list (directory-list dest-dir #:build? #t))])
(when (directory-exists? f) (when (directory-exists? f)
(create-info-as-needed mode f 'collection)))])) (create-info-as-needed mode f 'collection)))]))
(define (check-directory-exists who which dir)
(unless (directory-exists? dir)
(raise (exn:fail:filesystem
(format (string-append
"~a: destination ~adirectory does not exist\n"
" path: ~a")
who
which
dir)
(current-continuation-marks)))))