Megatest

Check-in [21f45d51cf]
Login
Overview
Comment:Added host name to messages about server not started
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: 21f45d51cf103a073f39f21e8db54d7b8fe6aa69
User & Date: mmgraham on 2023-04-09 13:27:11
Other Links: branch diff | manifest | tags
Context
2023-04-10
11:58
Merged fork check-in: 962cf22780 user: mrwellan tags: v1.80
2023-04-09
13:27
Added host name to messages about server not started check-in: 21f45d51cf user: mmgraham tags: v1.80
2023-04-07
08:25
Added switchable support for db on /tmp instead of inmem. Added couple asserts to help find why run-id and servers are not aligned in some cases. check-in: cfcc13973c user: matt tags: v1.80
Changes

Modified dbfile.scm from [cf63c9cd5f] to [3323e46fc8].

1303
1304
1305
1306
1307
1308
1309


1310
1311
1312

1313
1314
1315



1316
1317
1318
1319
1320
1321
1322
1323
1324
1325

1326
1327
1328
1329
1330
1331
1332


1333


1334
1335
1336
1337
1338
1339
1340
;; to get the lock
;;
(define (dbfile:simple-file-lock fname #!key (expire-time 300))
  (let ((fmod-time (handle-exceptions
		       ext
		     (current-seconds)
		     (file-modification-time fname))))


    (if (file-exists? fname)
	(if (> (- (current-seconds) fmod-time) expire-time)
	    (begin

	      (handle-exceptions exn #f (delete-file* fname))	
	      (dbfile:simple-file-lock fname expire-time: expire-time))
	    #f)



	(let ((key-string (conc (get-host-name) "-" (current-process-id)))
	      (oup        (open-output-file fname)))
	  (with-output-to-port
	      oup
	    (lambda ()
	      (print key-string)))
	  (close-output-port oup)
	  #;(with-output-to-file fname ;; bizarre. with-output-to-file does not seem to be cleaning up after itself.
	    (lambda ()
	  (print key-string)))

	  (thread-sleep! 0.25)
	  (if (file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))


	      #f)


       )
    )
  )
)

(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
  (let ((end-time (+ expire-time (current-seconds))))







>
>



>


|
>
>
>
|






|
|
|
>







>
>
|
>
>







1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
;; to get the lock
;;
(define (dbfile:simple-file-lock fname #!key (expire-time 300))
  (let ((fmod-time (handle-exceptions
		       ext
		     (current-seconds)
		     (file-modification-time fname))))

    ;; if the file exists, if it has expired, delete it and call this function recursively.
    (if (file-exists? fname)
	(if (> (- (current-seconds) fmod-time) expire-time)
	    (begin
              (dbfile:print-err "simple-file-lock: removing expired file: " fname)
	      (handle-exceptions exn #f (delete-file* fname))	
	      (dbfile:simple-file-lock fname expire-time: expire-time))
	    #f
        )

        ;; If it doesn't exist, write the host name and process id to the file
	(let ((key-string (conc (get-host-name) "-" (current-process-id) ": " (argv)))
	      (oup        (open-output-file fname)))
	  (with-output-to-port
	      oup
	    (lambda ()
	      (print key-string)))
	  (close-output-port oup)


          ;; sleep 3 seconds and make sure it still exists and contains the same host/process id.
          ;; if not, return #f
	  (thread-sleep! 0.25)
	  (if (file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))
              (begin
                 (dbfile:print-err "dbfile:simple-file-lock created " fname " but it was gone 3 seconds later")
	         #f
              )
          )
       )
    )
  )
)

(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
  (let ((end-time (+ expire-time (current-seconds))))
1350
1351
1352
1353
1354
1355
1356

1357


1358
1359
1360
1361
1362
1363
1364
1365
1366

1367

1368
1369
1370
1371
1372
1373
1374
(define (dbfile:simple-file-release-lock fname)
  (handle-exceptions
      exn
      #f ;; I don't really care why this failed (at least for now)
    (delete-file* fname)))

(define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300))

  (let ((gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time)))


    (if gotlock
	(let ((res (proc)))
	  (dbfile:simple-file-release-lock fname)
	  res)
        (begin
          (dbfile:print-err "dbfile:with-simple-file-lock: " fname " is locked by " )
          (with-input-from-file fname
             (lambda ()
                (dbfile:print-err (read-line))))

	  (assert #f (conc "ERROR: simple file lock could not get a lock for " fname " in " expire-time " seconds"))

        )
    )
  )
)


(define *get-cache-stmth-mutex* (make-mutex))







>
|
>
>









>
|
>







1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
(define (dbfile:simple-file-release-lock fname)
  (handle-exceptions
      exn
      #f ;; I don't really care why this failed (at least for now)
    (delete-file* fname)))

(define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300))
  (let ((start-time (current-seconds))
        (gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time))
        (end-time (current-seconds))
        )
    (if gotlock
	(let ((res (proc)))
	  (dbfile:simple-file-release-lock fname)
	  res)
        (begin
          (dbfile:print-err "dbfile:with-simple-file-lock: " fname " is locked by " )
          (with-input-from-file fname
             (lambda ()
                (dbfile:print-err (read-line))))
          (dbfile:print-err "wait time = " (- end-time start-time))
	  (dbfile:print-err "ERROR: simple file lock could not get a lock for " fname " in " expire-time " seconds")
          #f
        )
    )
  )
)


(define *get-cache-stmth-mutex* (make-mutex))

Modified tcp-transportmod.scm from [a71da4bf27] to [347b2c4dd7].

602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
  (assert mtexe     "FATAL: tt:server-process-run called without mtexe defined.")
  ;; mtest -server - -m testsuite:ext-tests -db 6.db
  (let* ((dbfname  (dbmod:run-id->dbfname run-id))
	 (load     (get-normalized-cpu-load))
	 (nrun     (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
    (cond
     ((> load 2.0)
      (debug:print 0 *default-log-port* "Normalized load "load" is over the limit of 2.0. Not starting a server.")
      (thread-sleep! 1))
     ((> nrun 100)
      (debug:print 0 *default-log-port* nrun" servers running on this host, not starting another.")
      (thread-sleep! 1))
     (else
      (if (not (file-exists? (conc areapath"/logs")))
	      (create-directory (conc areapath"/logs") #t))
	  (let* ((logfile   (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log"))
		 (cmdln     (conc
			     mtexe







|


|







602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
  (assert mtexe     "FATAL: tt:server-process-run called without mtexe defined.")
  ;; mtest -server - -m testsuite:ext-tests -db 6.db
  (let* ((dbfname  (dbmod:run-id->dbfname run-id))
	 (load     (get-normalized-cpu-load))
	 (nrun     (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
    (cond
     ((> load 2.0)
      (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server.")
      (thread-sleep! 1))
     ((> nrun 100)
      (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
      (thread-sleep! 1))
     (else
      (if (not (file-exists? (conc areapath"/logs")))
	      (create-directory (conc areapath"/logs") #t))
	  (let* ((logfile   (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log"))
		 (cmdln     (conc
			     mtexe