Megatest

;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================

(use posix srfi-18)


(if (< (length (command-line-arguments)) 2) ;; require at least lockfile command
    (begin
      (print "Usage: 
softlock lockfile command args ...

Softlock does weak, transient locking. This is useful to slow down a
deluge of events that can overwhelm hardware or software systems.

Locks are only good for two seconds, just enough time to spread things
out.

On NFS file locking works well but the lock handling on the filers can
be overwhelmed by too many locks occuring too quickly. Jobs that must
use NFS file locks can use softlock to minimize the rate that the file
locks are created, preventing the NFS filer from being swamped.

Environment variables:

  SOFTLOCK_DEBUG_MODE - if defined enable some messages

WARNING: the file <lockfile>.softlock will be overwritten and removed by softlock!

Part of the Megatest project http://www.kiatoa.com/fossils/megatest")
      (exit 1)))

(define (read-lock-file fname)
  (handle-exceptions
   exn
   (begin
     (if (get-environment-variable "SOFTLOCK_DEBUG_MODE")
	 (print "Exception on reading lock file. exn=" exn))
     #f)
   (with-input-from-file fname
     read-line)))

(define (lock-file-old fname)
  (and (file-exists? fname)
       (> (- (current-seconds)(file-modification-time fname)) 1))) ;; hard coded to one second

(define (check-locked-by-me fname mykey)
  (if (file-exists? fname)
      (let ((lock-data (read-lock-file fname)))
	(if (and lock-data
		 (equal? mykey lock-data))
	    #t
	    (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked.
      #f))
		
(define (check-locked-by-someone-else fname mykey)
  (if (file-exists? fname)
      (let ((lock-data (read-lock-file fname)))
	(and lock-data
	     (not (equal? mykey lock-data))
	     (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked.
      #f))

(define (take-lock fname mykey)
  (with-output-to-file fname
    (lambda ()
      (print mykey))))

(define (run-the-command command params)
  (process-wait (process-run command params)))

(let* ((lockfile (car (command-line-arguments)))
       (fulllock (conc lockfile ".softlock")) ;; prevent accidentally removing important files
       (lockfdir (pathname-directory lockfile))
       (command  (cadr (command-line-arguments)))
       (params   (cddr (command-line-arguments)))
       (mykey    (conc (get-host-name) "-" (current-process-id))))
  
  ;; sanity checks
  (cond
   ((not lockfdir)
    (print "ERROR: lock file parameter must include path component, e.g. ./mylock")
    (exit 1))
   ((not (file-write-access? lockfdir))
    (print "ERROR: Can not access directory for lock " lockfdir)
    (exit 1))
   ;; add more sanity checks here
   )

  (let loop ((remtries 10))
    (if (> remtries 0)
	(if (check-locked-by-someone-else fulllock mykey)
	    (begin
	      (print "... lock " fulllock " exists, waiting...")
	      (thread-sleep! 1.9)
	      (loop (- remtries 1)))
	    (begin
	      (take-lock fulllock mykey)
	      (if (check-locked-by-me fulllock mykey)
		  (run-the-command command params)
		  (begin ;; didn't get the lock
		    (thread-sleep! (+ 1.9 (/ 1 (+ 1 (random 20))))) ;; add some noise to prevent nyquist problems
		    (loop (- remtries 1))))))
	(begin
	  (print "ERROR: not able to get the lock. Gonna take it and proceed...")
	  (take-lock fulllock mykey)
	  (run-the-command command params)))))