diff --git a/scsh/dot-locking.scm b/scsh/dot-locking.scm index cc4bfd3..92813b1 100644 --- a/scsh/dot-locking.scm +++ b/scsh/dot-locking.scm @@ -1,56 +1,76 @@ -(define (make-lockname filename) - (string-append filename ".lock")) +(define (make-lock-file-name file-name) + (string-append file-name ".lock")) -(define (maybe-obtain-dot-lock tempname filename) - (let ((port (open-file tempname (bitwise-ior open/write - open/create - open/exclusive)))) - (close port) - (with-errno-handler - ((errno packet) - ((errno/exist) - (delete-file tempname) - #f)) - (create-hard-link tempname (make-lockname filename)) - (delete-file tempname) - #t))) - -(define (release-dot-lock filename) +(define (release-dot-lock file-name) (with-errno-handler ((errno packet) (else #f)) - (delete-file (make-lockname filename)) + (delete-file (make-lock-file-name file-name)) #t)) -(define (obtain-dot-lock filename . args) - (let-optionals args ((retry-interval 1000) (retry-number #f)) - (let ((tempname (create-temp-file filename))) - (delete-file tempname) - (let loop ((retry-number retry-number)) - (or (maybe-obtain-dot-lock tempname filename) - (begin (sleep retry-interval) - (cond ((not retry-number) - (loop retry-number)) - ((> retry-number 0) - (loop (- retry-number 1))) - (else #f)))))))) +(define (maybe-obtain-dot-lock file-name) + (let ((temp-name (create-temp-file file-name))) + (with-errno-handler + ((errno packet) + ((errno/exist) + (delete-file temp-name) + #f)) + (create-hard-link temp-name (make-lock-file-name file-name)) + (delete-file temp-name) + #t))) -(define (with-dot-lock* filename thunk) +(define random + (let ((crank (make-random (modulo (time) (- (expt 2 27) 1))))) + (lambda (limit) + (quotient (* (modulo (crank) 314159265) + limit) + 314159265)))) + +;; STALE-TIME is the minimum age of a lock to be broken +;; if #f, don't break the lock + +(define (obtain-dot-lock file-name retry-interval retry-number stale-time) + (let ((lock-file-name (make-lock-file-name file-name))) + (let loop ((retry-number retry-number)) + (cond + ((maybe-obtain-dot-lock file-name) + #t) + ((and stale-time + (with-errno-handler + ((errno packet) + (else #f)) + (> (time) + (+ (file-last-status-change (make-lock-file-name file-name)) + stale-time)))) + (with-errno-handler + ((errno packet) + ((errno/noent) 'dont-care)) + (delete-file lock-file-name)) + (loop retry-number)) + (else + (sleep (+ (quotient (* retry-interval 3) 4) + (random (quotient retry-interval 2)))) + (cond ((not retry-number) + (loop retry-number)) + ((> retry-number 0) + (loop (- retry-number 1))) + (else #f))))))) + +(define (with-dot-lock* file-name thunk) (dynamic-wind - (lambda () - (obtain-dot-lock filename)) - (lambda () - (call-with-values thunk - (lambda a - (release-dot-lock filename) - (apply values a)))) - (lambda () - (release-dot-lock filename)))) + (lambda () + (obtain-dot-lock file-name)) + (lambda () + (call-with-values thunk + (lambda a + (release-dot-lock file-name) + (apply values a)))) + (lambda () + (release-dot-lock file-name)))) (define-syntax with-dot-lock - (syntax-rules - () - ((with-dot-lock filename body ...) - (with-dot-lock* filename (lambda () body ...))))) + (syntax-rules () + ((with-dot-lock file-name body ...) + (with-dot-lock* file-name (lambda () body ...))))) diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index bc6708e..f51221a 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -464,7 +464,8 @@ (open scsh-level-0 scheme let-opt - threads) ; sleep + threads ; sleep + random) (files dot-locking)) (define-structures ((syslog syslog-interface)