DELETED utils/softlock.scm Index: utils/softlock.scm ================================================================== --- utils/softlock.scm +++ /dev/null @@ -1,124 +0,0 @@ -;;====================================================================== -;; 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 . -;; -;;====================================================================== - -(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 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 .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))))) ADDED utils/softlock/Makefile Index: utils/softlock/Makefile ================================================================== --- /dev/null +++ utils/softlock/Makefile @@ -0,0 +1,11 @@ +#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 ADDED utils/softlock/softlock.scm Index: utils/softlock/softlock.scm ================================================================== --- /dev/null +++ utils/softlock/softlock.scm @@ -0,0 +1,135 @@ +;;====================================================================== +;; 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 . +;; +;;====================================================================== + +(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 .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)))))