call-with-file-lock/timeout

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)
+(define (call-with-file-lock/timeout fn kind thunk failure-thunk
-  (case (preferences-lock-file-mode)
+    #: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:
-       ;; Create the lock file if it doesn't exist:
+      (unless (file-exists? lock-file)
-       (unless (file-exists? lock-file)
+        (with-handlers ([exn:fail:filesystem:exists? (lambda (exn) 'ok)])
-         (with-handlers ([exn:fail:filesystem:exists? (lambda (exn) 'ok)])
+          (close-output-port (open-output-file lock-file #:exists 'error))))
-           (close-output-port (open-output-file lock-file #:exists 'error))))
+      ((call-with-input-file* 
-       ((call-with-input-file* 
+        lock-file
-         lock-file
+        (lambda (p)
-         (lambda (p)
+          (if (port-try-file-lock? p kind)
-           (if (port-try-file-lock? p kind)
+              ;; got lock:
-               ;; got lock:
+              (let ([v (dynamic-wind
-               (let ([v (dynamic-wind
+                           void
-                            void
+                           thunk
-                            thunk
+                           (lambda ()
-                            (lambda ()
+                             (port-file-unlock p)))])
-                              (port-file-unlock p)))])
+                (lambda () v))
-                 (lambda () v))
+              ;; didn't get lock:
-               ;; didn't get lock:
+              (lambda () (failure-thunk))))))]
-               (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)))))))]
     [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? 
-          (with-handlers ([exn:fail:filesystem:exists?
+                         (lambda (x) (failure-thunk))])
-                           (lambda (x)
+          ;; Grab lock:
-                             (if lock-there
+          (close-output-port (open-output-file lock-file #:exists 'error)))
-                                 (lock-there lock-file)
+        (dynamic-wind 
-                                 (error who
+            void
-                                        "~a, ~a: ~e"
+            thunk
-                                        "some other process has the preference-file lock"
+            (lambda ()
-                                        "as indicated by the existence of the lock file"
+              ;; Release lock:
-                                        lock-file)))])
+              (delete-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))))])]))
 
 (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
+                            (call-with-preference-file-lock
-                             'get-preference
+                             '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)

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)

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