Megatest

#Need a chicken 5.1.0 with system-information egg installed in your path 

.DEFAULT : all

all : softlock

softlock : softlock.scm
	csc -static -L -static -L -lm -L -dl -L -lpthread -L -lcrypto -L -lz softlock.scm 

clean: 
	rm softlock *.o

;;======================================================================
;; 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/>.
;;
;;======================================================================

(import (chicken string) 
        (chicken pathname) 
        system-information 
        (chicken file posix) 
        (chicken process-context posix) 
        (chicken process-context) 
        (chicken process) 
        (chicken file posix) 
        (chicken file) 
        (chicken time) 
        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 one second, just enough time to spread events
out.

On NFS the Unix file locking mechanism works well but lock handling on
the filers can be overwhelmed by many locks occuring 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-writable? 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)))))