;;;; dot-locking.scm


(module dot-locking (break-dot-lock
		     obtain-dot-lock
		     release-dot-lock
		     with-dot-lock*
		     with-dot-lock)

(import scheme (chicken base))
(import (chicken time) 
        (chicken file)
        (chicken condition)
        (chicken random)
        (chicken process-context)
        (chicken pathname)
        (chicken file posix))
(import srfi-13 srfi-18)


(define (norm-abs-name file-name)
  (normalize-pathname
    (if (absolute-pathname? file-name)
      file-name
      (make-absolute-pathname (current-directory) file-name))))

(define (make-lock-file-name file-name)
  (string-append (norm-abs-name file-name) ".lock"))

(define (release-dot-lock file-name)
  (delete-file* (make-lock-file-name file-name)))

(define (maybe-obtain-dot-lock file-name)
  (let ((temp-name (create-temporary-file)))
    (handle-exceptions ex
	(begin
	  (delete-file temp-name)
	  #f)
      (file-link temp-name (make-lock-file-name file-name))
      (delete-file temp-name)
      #t)))

;; 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 . args)
  (let-optionals args ((retry-seconds 1)
		       (retry-number #f)
		       (stale-time 300))
    (let ((lock-file-name (make-lock-file-name file-name))
	  (retry-interval retry-seconds))
      (let loop ((retry-number retry-number)
		 (broken? #f))
	(cond
	 ((maybe-obtain-dot-lock file-name)
	  (if broken?
	      'broken
	      #t))
	 ((and stale-time
	       (handle-exceptions ex #f
		 (> (current-seconds)
		    (+ (file-modification-time lock-file-name)
		       stale-time))))
	  (break-dot-lock file-name)
	  (loop retry-number #t))
	 (else
	  (thread-sleep!
	   (+ 1 (quotient (* retry-interval 3) 4)
	      (pseudo-random-integer (quotient retry-interval 2))))
	  (cond ((not retry-number)
		 (loop retry-number broken?))
		((> retry-number 0)
		 (loop (- retry-number 1) broken?))
		(else
		 #f))))))))

(define (break-dot-lock file-name)
  (delete-file* (make-lock-file-name file-name)))

(define (with-dot-lock* file-name thunk)
  (dynamic-wind
   (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 file-name body ...)
    (with-dot-lock* file-name (lambda () body ...)))))

)