;; implements a locking system for files working even around NFS
;; needs write permission to create and write to filename and directory

;;AUTOLOAD: file-lock
;;AUTODOC: file-lock "creates a file lock for exclusive usage"
;;(file-lock lock-filename
;;    :file actual-lock-name-is-filename.lck
;;    :time seconds
;;    :timeout seconds
;;    :reset flag
;;    :retry milliseconds between retries
;;    :error error-expression
;;)
;;
;;Locks a file, i.e. try to gain exclusive access to an UNIX file, or blocks
;;till it gets access or the number of seconds specified (defaut 10)
;;by :timeout keyword. During this blocking, retries each "retry" time 
;;(default 100ms) to poll the lock state.
;;when lock ownership is granted, info is written into the file on the time at
;;which the lock was established and the time at which the lock will be 
;;considered obsolete and can be deleted
;;At the end of timeout, if the keyword :reset is set to t (default), then 
;;the lock is forcibly resetted, assuming the process owning the lock is
;;dead. If :reset is (), then file-lock returns (), instead of returning t for
;;success
;;If timeout is 0, one poll is made, so (file-lock name :timeout 0 :reset ())
;;can be used just try to set the lock without waiting, and return t when lock
;;is established.
;;WARNING: the file "filename" is created and thus must not be the name of an
;; existing file or it will be overwritten!!!
;;If you want to lock some precise file, use the keyword :file to t so that the
;;lock will be in fact (+ filename ".lck")
;;NOTE: this lock mecanism is done "by hand" in order to work across NFS systems
;;but the reset system is not totally foolproof. It works by trying to create 
;;filename, creating it establishing the lock, and its presence blocking the
;;lock call. You must thus choose a filename not corresponding to an
;;existing filename. The lock file will contain a p-list with fields:
;;    user    the user login name
;;    name    the name of the application (get *arguments* 0)
;;    host    the *hostname* of the process which established the lock
;;    pid     its *current-process-id* 
;;    begin   the time of lock creation (in seconds from 1Jan70)
;;    end     the time at which lock can be resetted (in seconds from 1Jan70)
;;In case of error, an error Errors:CannotLockFile is triggered, unless () is 
;;given to :error (for no error message) or a labmda which will be applied to 2 
;;arguments, the filename and a string describing the error, which can be:
;;    * "cannot create lock file" if the file could not be created in dir
;;      (write permissions?)
;;    * "cannot reset lock" when resetting, unable to reset the file
;;    * "file system full" lock file could be created but file system was full
;;      and lock operation could not be completed
;;
;;The lock MUST be resetted after use by (file-unlock filename [:file t]), 
;;which simply removes the file "filename" (or filename.lck if :file is set).

;;AUTOLOAD: file-unlock
;;AUTODOC: file-unlock "unlocks file locked by file-lock"
;;(file-unlock filename)
;;
;;remove the lock set on the file by a previous file-lock
;;dont complain if a lock wasnt set on the file or file does not exist

(defvar Errors:CannotLockFile "Cannot lock file %0 (%1)")

(defun file-lock (filename &key 
    (time 60)
    (timeout 10)
    (retry 100)
    (file ())
    ((error errfunc) '(lambda (filename errtype)
	(error Errors:CannotLockFile filename errtype)
    ))
    (reset t)
    &aux
    (lockname (if file (+ filename ".lck") filename))
    fd
    (*umask* 0)				;ensure locks are remote-brokable
  )
  ;; try to create a lock
  (if (not (setq fd 
	(open lockname :direction :io :if-exists :error :error ()))) ;error
    ;; see if we can open the file
    (if (not (with (fd 
	  (open lockname :direction :output :if-exists :append :error ()))
	  (if fd (close fd))
	  fd
      ))
      (apply (eval errfunc) (list filename "cannot create lock file"))
      ;; else Ok, enter loop
      (if (catch 'FAILED
	  (dotimes (i (/ (* 1000 timeout) retry))
	    (select :timeout retry)	;sleeps retry (3/10th of a second)
	    (if (setq fd
		(open lockname :direction :io :if-exists :error :error ()))
	      (throw 'FAILED ())		;yeah! at last!
	  ))
	  t
	)
	(if (and reset			;failed
	  (not (setq fd (open lockname :direction :output 
		  :if-exists :supersede :error ()
	  ))))
	  ;; reset by rewriting the contents
	  (apply (eval errfunc) (list filename "cannot reset lock"))
  ))))
  ;; lock established if fd, and to be filled if /= t
  
  (if (and fd (/= fd t)) 
    (if (not (trap-error 'Errors:StreamError
	  (print-format fd 
	    "Name: %r0\nHost: %r1\nPid: %2\nDate: %r3\nTimeout: %4\n"
	    (get *arguments* 0 "???") *hostname* *current-process-id* (cur-date)
	    timeout
	  )
	  (close fd)
	  t				;since () is returned in error
      ))
      ;; argh, file system full
      (progn
	(trap-error 'ALL (close fd))
	(sh rm ,lockname)
	(apply (eval errfunc) (list filename "file system full"))
  )))
  (if fd t ())
)

(defun file-unlock (filename &key (file ()))
  (if file (setq filename (+ filename ".lck")))
  (= 0 (wait (system (list "rm" "-f" (expand-filename filename)))))
)
