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

call-with-file-lock/timeout

Browse Source
This commit is contained in:
Kevin Tew 2011-01-20 09:30:19 -07:00
parent 64521e70ea
commit bc580ac125
3 changed files with 178 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/racket/file.rkt
View File

@ -9,6 +9,8 @@
put-preferences
preferences-lock-file-mode
make-handle-get-preference-locked
make-lock-file-name
call-with-file-lock/timeout
fold-files
find-files
@ -161,10 +163,65 @@
[(windows) 'file-lock]
[else 'exists]))
(define (call-with-file-lock who kind get-lock-file thunk lock-there)
(case (preferences-lock-file-mode)
(define (call-with-file-lock/timeout fn kind thunk failure-thunk
#:get-lock-file [get-lock-file (make-lock-file-name fn)]
#:delay [delay 0.01]
#:max-delay [max-delay 0.2])
(unless (or (path-string? fn) (eq? fn #f))
(raise-type-error 'call-with-file-lock/timeout "path-string? or #f" fn))
(unless (or (eq? kind 'shared) (eq? kind 'exclusive))
(raise-type-error 'call-with-file-lock/timeout "'shared or 'exclusive" kind))
(unless (= (procedure-arity thunk) 0)
(raise-type-error 'call-with-file-lock/timeout "procedure (arity 0)" thunk))
(unless (= (procedure-arity failure-thunk) 0)
(raise-type-error 'call-with-file-lock/timeout "procedure (arity 0)" failure-thunk))
(unless (or (path-string? get-lock-file)
(= (procedure-arity get-lock-file) 0))
(raise-type-error 'call-with-file-lock/timeout "procedure (arity 0)" get-lock-file))
(unless (and (real? delay) (not (negative? delay)))
(raise-type-error 'call-with-file-lock/timeout "non-negative real" delay))
(unless (and (real? max-delay) (not (negative? max-delay)))
(raise-type-error 'call-with-file-lock/timeout "non-negative real" max-delay))
(define real-get-lock-file
(if (procedure? get-lock-file) (get-lock-file) get-lock-file))
(call-with-file-lock
kind
real-get-lock-file
thunk
(lambda ()
(if (delay . < . max-delay)
(begin
(sleep delay)
(call-with-file-lock/timeout fn kind thunk failure-thunk #:delay (* 2 delay)
#:get-lock-file real-get-lock-file
#:max-delay max-delay))
(failure-thunk)))))
(define (call-with-preference-file-lock who kind get-lock-file thunk lock-there)
(define lock-style (preferences-lock-file-mode))
(define lock-file (get-lock-file))
(define failure-thunk
(if lock-there
(lambda () (lock-there lock-file))
(case lock-style
[(file-lock) (error who
"~a ~a: ~e"
"some other process has a lock"
"on the preferences lock file"
lock-file)]
[else (error who
"~a, ~a: ~e"
"some other process has the preference-file lock"
"as indicated by the existence of the lock file"
lock-file)])))
(call-with-file-lock kind lock-file thunk failure-thunk #:lock-style lock-style))
(define (call-with-file-lock kind lock-file thunk failure-thunk #:lock-style [lock-style 'file-lock])
(case lock-style
[(file-lock)
(let ([lock-file (get-lock-file)])
;; Create the lock file if it doesn't exist:
(unless (file-exists? lock-file)
(with-handlers ([exn:fail:filesystem:exists? (lambda (exn) 'ok)])
@ -181,29 +238,15 @@
(port-file-unlock p)))])
(lambda () v))
;; didn't get lock:
(if lock-there
(lambda () (lock-there lock-file))
(error who
"~a ~a: ~e"
"some other process has a lock"
"on the preferences lock file"
lock-file)))))))]
(lambda () (failure-thunk))))))]
[else ; = 'exists
;; Only a write lock is needed, and the file lock
;; is implemented by the presence of the file:
(case kind
[(shared) (thunk)]
[(exclusive)
(let ([lock-file (get-lock-file)])
(with-handlers ([exn:fail:filesystem:exists?
(lambda (x)
(if lock-there
(lock-there lock-file)
(error who
"~a, ~a: ~e"
"some other process has the preference-file lock"
"as indicated by the existence of the lock file"
lock-file)))])
(lambda (x) (failure-thunk))])
;; Grab lock:
(close-output-port (open-output-file lock-file #:exists 'error)))
(dynamic-wind
@ -211,7 +254,7 @@
thunk
(lambda ()
;; Release lock:
(delete-file lock-file))))])]))
(delete-file lock-file)))])]))
(define (get-prefs flush-mode filename use-lock? lock-there)
(define (read-prefs default-pref-file)
@ -248,8 +291,8 @@
(let ([prefs (with-pref-params
(lambda ()
(if use-lock?
(call-with-file-lock
'get-preference
(call-with-preference-file-lock
'get-preferences
'shared
(lambda ()
(make-lock-file-name pref-file))
@ -349,7 +392,7 @@
filename
(make-lock-file-name dir name)
dir))))])
(call-with-file-lock
(call-with-preference-file-lock
'put-preferences
'exclusive
(lambda () lock-file)

65
collects/scribblings/reference/filesystem.scrbl
View File

@ -4,6 +4,10 @@
racket/runtime-path
setup/dirs))
@(define file-eval (make-base-eval))
@(interaction-eval #:eval file-eval (begin (require racket/file) (define filename (make-temporary-file))))
@title{Filesystem}
@;------------------------------------------------------------------------
@ -991,7 +995,7 @@ the file via @racket[rename-file-or-directory].)}
[name symbol?]
[failure-thunk (-> any) (lambda () #f)]
[flush-mode any/c 'timestamp]
[filename (or/c string-path? #f) #f]
[filename (or/c path-string? #f) #f]
[#:lock-there lock-there (or/c (path? . -> . any) #f) #f]
[#:max-delay max-delay real? 0.2])
(path-string? . -> . any)]{
@ -1005,8 +1009,67 @@ to retry the preferences lookup.
Before calling @racket[get-preference], the result procedure uses
@racket[(sleep delay)] to pause. Then, if @racket[(* 2 delay)] is less
than @racket[max-delay], the result procedure calls
@racket[make-handle-get-preference-locked] to generate a new retry
procedure to pass to @racket[get-preference], but with a
@racket[delay] of @racket[(* 2 delay)]. If @racket[(* 2 delay)] is not
less than @racket[max-delay], then @racket[get-preference] is called
with the given @racket[lock-there], instead.}
@defproc[(call-with-file-lock/timeout
[filename (or/c path-string? #f)]
[kind (or/c 'shared 'exclusive)]
[thunk (-> any)]
[failure-thunk (-> any)]
[#:get-lock-file get-lock-file (-> path-string?) (lambda () (make-lock-filename filename))]
[#:delay delay real? 0.01]
[#:max-delay max-delay real? 0.2])
any]{
Obtains a lock for the filename returned from @racket[(get-lock-file)] and then
calls @racket[thunk]. When @racket[thunk] returns,
@racket[call-with-file-lock] releases the lock, returning the result of
@racket[thunk]. The @racket[call-with-file-lock/timeout] function will retry
after @racket[#:delay] seconds and continue retrying with exponential backoff
until delay reaches @racket[#:max-delay]. If
@racket[call-with-file-lock/timeout] fails to obtain the lock,
@racket[failure-thunk] is called in tail position. The @racket[kind] argument
specifies whether the lock is @racket['shared] or @racket['exclusive]
The @racket[filename] argument specifies a file path prefix that is only used
to generate the lock filename, when @racket[#:get-lock-file] is not present.
The @racket[call-with-file-lock/timeout] function uses a separate lock file to
prevent race conditions on @racket[filename], when @racket[filename] has not yet
been created. On the Windows platfom, the @racket[call-with-file-lock/timeout]
function uses a separate lock file (@racket["_LOCKfilename"]), because a lock
on @racket[filename] would interfere with replacing @racket[filename]] via
@racket[rename-file-or-directory].
}
@examples[
#:eval file-eval
(call-with-file-lock/timeout filename 'exclusive
(lambda () (printf "File is locked\n"))
(lambda () (printf "Failed to obtain lock for file\n")))
(call-with-file-lock/timeout #f 'exclusive
(lambda ()
(call-with-file-lock/timeout filename 'shared
(lambda () (printf "Shouldn't get here\n"))
(lambda () (printf "Failed to obtain lock for file\n"))))
(lambda () (printf "Shouldn't ger here eithere\n"))
#:get-lock-file (lambda () (make-lock-file-name filename)))]
@defproc*[([(make-lock-file-name [path path-string?]) path-string?]
[(make-lock-file-name [dir path-string?] [name path-string?]) path-string?])]{
Creates a lock filename by prepending @racket["_LOCK"] on windows or @racket[".LOCK"] on all other platforms
to the file portion of the path.
}
@examples[
#:eval file-eval
(make-lock-file-name "/home/george/project/important-file")]
@(interaction-eval #:eval file-eval (delete-file filename))
@(close-eval file-eval)

24
collects/tests/racket/file.rktl
View File

@ -1289,6 +1289,30 @@
'(close-input-port r2))))
(tcp-close l))
;;----------------------------------------------------------------------
;; File Locks
(define tempfile (make-temporary-file))
(err/rt-test (call-with-file-lock/timeout 10 'shared (lambda () #t) (lambda () #f)))
(err/rt-test (call-with-file-lock/timeout tempfile 'bogus (lambda () #t) (lambda () #f)))
(err/rt-test (call-with-file-lock/timeout tempfile 'shared (lambda (x) #t) (lambda () #f)))
(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda () #t) (lambda (x) #f)))
(test #t call-with-file-lock/timeout tempfile 'shared (lambda () #t) (lambda () #f))
(test #t call-with-file-lock/timeout tempfile 'exclusive (lambda () #t) (lambda () #f))
(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda ()
(call-with-file-lock/timeout tempfile 'exclusive (lambda () #f) (lambda () (error))))
(lambda () 'uhoh)))
(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda ()
(call-with-file-lock/timeout tempfile 'shared (lambda () #f) (lambda () (error))))
(lambda () 'uhon)))
(err/rt-test (call-with-file-lock/timeout tempfile 'shared (lambda ()
(call-with-file-lock/timeout tempfile 'exclusive (lambda () #f) (lambda () (error))))
(lambda () 'uhoh)))
(test #t call-with-file-lock/timeout tempfile 'shared (lambda ()
(call-with-file-lock/timeout tempfile 'shared (lambda () #t) (lambda () #f)))
(lambda () 'uhoh))
;;----------------------------------------------------------------------
;; TCP