From bc580ac12529e2be85f0db62b5f56d047f54a2ea Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Thu, 20 Jan 2011 09:30:19 -0700 Subject: [PATCH] call-with-file-lock/timeout --- collects/racket/file.rkt | 137 ++++++++++++------ .../scribblings/reference/filesystem.scrbl | 65 ++++++++- collects/tests/racket/file.rktl | 24 +++ 3 files changed, 178 insertions(+), 48 deletions(-) diff --git a/collects/racket/file.rkt b/collects/racket/file.rkt index 93b83c6839..acb2caad06 100644 --- a/collects/racket/file.rkt +++ b/collects/racket/file.rkt @@ -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,57 +163,98 @@ [(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)]) - (close-output-port (open-output-file lock-file #:exists 'error)))) - ((call-with-input-file* - lock-file - (lambda (p) - (if (port-try-file-lock? p kind) - ;; got lock: - (let ([v (dynamic-wind - void - thunk - (lambda () - (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)))))))] + ;; Create the lock file if it doesn't exist: + (unless (file-exists? lock-file) + (with-handlers ([exn:fail:filesystem:exists? (lambda (exn) 'ok)]) + (close-output-port (open-output-file lock-file #:exists 'error)))) + ((call-with-input-file* + lock-file + (lambda (p) + (if (port-try-file-lock? p kind) + ;; got lock: + (let ([v (dynamic-wind + void + thunk + (lambda () + (port-file-unlock p)))]) + (lambda () v)) + ;; didn't get lock: + (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)))]) - ;; Grab lock: - (close-output-port (open-output-file lock-file #:exists 'error))) - (dynamic-wind - void - thunk - (lambda () - ;; Release lock: - (delete-file lock-file))))])])) + (with-handlers ([exn:fail:filesystem:exists? + (lambda (x) (failure-thunk))]) + ;; Grab lock: + (close-output-port (open-output-file lock-file #:exists 'error))) + (dynamic-wind + void + thunk + (lambda () + ;; Release lock: + (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) diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index 7ef5b0eae8..e9cf91fb89 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -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) diff --git a/collects/tests/racket/file.rktl b/collects/tests/racket/file.rktl index 2663f4c405..5778ed34dc 100644 --- a/collects/tests/racket/file.rktl +++ b/collects/tests/racket/file.rktl @@ -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