Megatest

Changes On Branch 16d75bb8f135501a
Login

Changes In Branch v1.81-multi-server Through [16d75bb8f1] Excluding Merge-Ins

This is equivalent to a diff from 6b8bacba76 to 16d75bb8f1

2024-07-08
12:55
CI/CD: Automated commit after successful test, build, and deploy for v1.81-fix-api-changed check-in: 0249193b68 user: ramartin tags: v1.81
2024-07-03
19:08
Missing change check-in: 25cae1c008 user: mrwellan tags: v1.81-multi-server
19:06
Multi-servers working. Needs polish but the machine didn't overload on > 10 parallel runs of sixtyfivek check-in: 16d75bb8f1 user: matt tags: v1.81-multi-server
12:50
Fixed an unbound variable and made it handle 1.81. Leaf check-in: dc561cf357 user: mmgraham tags: v1.81-fix-api-changed
2024-07-02
13:55
Start on increasing allowed number of servers for a db file check-in: 66e4d2383a user: mrwellan tags: v1.81-multi-server
2024-07-01
17:27
Changed version to v1.8101 check-in: 6b8bacba76 user: mmgraham tags: v1.81, v1.8101
16:57
v1.81-test-control-panel branch into 1.81 check-in: a6b2094831 user: ramartin tags: v1.81

Modified api.scm from [bf55d9f0a8] to [03e4361c1a].

242
243
244
245
246
247
248







249


250
251
252
253
254
255
256
					 (else
					  (assert ok "FATAL: database file and run-id not aligned.")))))
			     (ttdat   *server-info*)
			     (server-state (tt-state ttdat))
			     (maxthreads   20) ;; make this a parameter?
			     (status  (cond
                                       ((> numthreads maxthreads)







					'busy)


				       (else 'ok)))
			     (errmsg  (case status
					((busy)   (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads)))
					((loaded) (conc "Server loaded, "numthreads" threads in flight"))
					(else     #f)))
			     (result  (case status
					((busy)







>
>
>
>
>
>
>
|
>
>







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
					 (else
					  (assert ok "FATAL: database file and run-id not aligned.")))))
			     (ttdat   *server-info*)
			     (server-state (tt-state ttdat))
			     (maxthreads   20) ;; make this a parameter?
			     (status  (cond
                                       ((> numthreads maxthreads)
					(let* ((testsuite (common:get-testsuite-name))
					       (mtexe     (common:find-local-megatest))
					       (proc      (lambda ()
							    ;; we are overloaded, try to start another server
							    (debug:print 0 *default-log-port* "Too many threads running, starting another server")
							    (tt:server-process-run *toppath* testsuite mtexe run-id))))
					  (set! *server-start-requests* (cons proc *server-start-requests*)))
					;; 'busy
					'loaded ;; not ideal since the client will not backoff
					)
				       (else 'ok)))
			     (errmsg  (case status
					((busy)   (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads)))
					((loaded) (conc "Server loaded, "numthreads" threads in flight"))
					(else     #f)))
			     (result  (case status
					((busy)
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
		     (else
		      (assert #f "FATAL: failed to deserialize indat "indat))))))
      ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))



(define *api-halt-writes* #f)

(define (api:dispatch-request dbstruct cmd run-id params)
  (if (not *no-sync-db*)
      (db:open-no-sync-db))
  (let* ((start-time (current-milliseconds)))







<
<







284
285
286
287
288
289
290


291
292
293
294
295
296
297
		     (else
		      (assert #f "FATAL: failed to deserialize indat "indat))))))
      ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))



(define *api-halt-writes* #f)

(define (api:dispatch-request dbstruct cmd run-id params)
  (if (not *no-sync-db*)
      (db:open-no-sync-db))
  (let* ((start-time (current-milliseconds)))

Modified common.scm from [1039cd02f7] to [098f0c5374].

399
400
401
402
403
404
405
406


407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422

(define (common:version-changed?)
  (not (equal? (common:get-last-run-version)
               (common:version-signature))))


;; From 1.70 to 1.80, db's are compatible.



(define (common:api-changed?)
  (let* (
    (megatest-major-version (substring (->string megatest-version) 0 4))
    (run-major-version (substring (conc (common:get-last-run-version)) 0 4))
   )
   (and (not (equal? megatest-major-version "1.80"))
     (not (equal? megatest-major-version megatest-run-version)))
  )
)

;;======================================================================
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
  (case (rmt:transport-mode)







|
>
>

<
|
|
<
|
|
<
<







399
400
401
402
403
404
405
406
407
408
409

410
411

412
413


414
415
416
417
418
419
420

(define (common:version-changed?)
  (not (equal? (common:get-last-run-version)
               (common:version-signature))))


;; From 1.70 to 1.80, db's are compatible.
;;
;; BUG: This logic is almost certainly not quite correct.
;;
(define (common:api-changed?)

  (let* ((megatest-major-version (substring (->string megatest-version) 0 4))
	 (run-major-version (substring (conc (common:get-last-run-version)) 0 4)))

    (and (not (member megatest-major-version '("1.81" "1.80")))
	 (not (equal? megatest-major-version run-major-version)))))



;;======================================================================
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
  (case (rmt:transport-mode)

Modified tcp-transportmod.scm from [2d80f8e52f] to [a9eba46ae1].

206
207
208
209
210
211
212

213
214
215
216
217
218
219
220
          (debug:print-info 2 *default-log-port* "already connected to a server for " dbfname)
           conn) ;; we are already connected to the server

	;; no conn
        (let* ((sdats (tt:get-server-info-sorted ttdat dbfname))
	       (sdat  (if (null? sdats)
			  #f

			  (car sdats))))
	   (debug:print-info 2 *default-log-port* "found sdat " sdat)
           (match sdat
	    ((host port start-time server-id pid dbfname2 servinffile)
	     (assert (equal? dbfname dbfname2) "FATAL: read server info from wrong file.")
             (debug:print-info 2 *default-log-port* "no conn - in match servinffile:" servinffile)
	     (let* ((host-port (conc host":"port))
		    (conn (make-tt-conn







>
|







206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
          (debug:print-info 2 *default-log-port* "already connected to a server for " dbfname)
           conn) ;; we are already connected to the server

	;; no conn
        (let* ((sdats (tt:get-server-info-sorted ttdat dbfname))
	       (sdat  (if (null? sdats)
			  #f
			  (let ((indx (max (random (- (length sdats) 1)) 0)))
			    (list-ref sdats indx)))))
	   (debug:print-info 2 *default-log-port* "found sdat " sdat)
           (match sdat
	    ((host port start-time server-id pid dbfname2 servinffile)
	     (assert (equal? dbfname dbfname2) "FATAL: read server info from wrong file.")
             (debug:print-info 2 *default-log-port* "no conn - in match servinffile:" servinffile)
	     (let* ((host-port (conc host":"port))
		    (conn (make-tt-conn
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
      (else
       ;; (debug:print 0 *default-log-port* "res not in form (status errmsg result meta), got: "res)
       (try-again)))))

;; client side handler
;;
;;(tt:handler #<tt> get-keys #f () 2 #f "/home/matt/data/megatest/ext-tests" #f "main.db" "ext-tests" "/home/matt/data/megatest/bin/.22.04/../megatest")
;;
(define (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)
  ;; connect-to-server will start a server if needed.
  (let* ((areapath (tt-areapath ttdat))
	 (conn     (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))) ;; looks up conn keyed by dbfname
    (if conn
	;; have connection, call the server
	(let* ((res (tt:send-receive ttdat conn cmd run-id params)))







|







302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
      (else
       ;; (debug:print 0 *default-log-port* "res not in form (status errmsg result meta), got: "res)
       (try-again)))))

;; client side handler
;;
;;(tt:handler #<tt> get-keys #f () 2 #f "/home/matt/data/megatest/ext-tests" #f "main.db" "ext-tests" "/home/matt/data/megatest/bin/.22.04/../megatest")
;;g
(define (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)
  ;; connect-to-server will start a server if needed.
  (let* ((areapath (tt-areapath ttdat))
	 (conn     (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))) ;; looks up conn keyed by dbfname
    (if conn
	;; have connection, call the server
	(let* ((res (tt:send-receive ttdat conn cmd run-id params)))
330
331
332
333
334
335
336



337
338
339
340
341
342
343
		  (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1))
                  (debug:print 0 *default-log-port* errmsg)
		  (thread-sleep! dly)
		  (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)))
	       ((loaded)
		(debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.")
		(tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn))



		result) ;; (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe))
	       (else
		result)))
	    (else ;; did not receive properly formated result
	     (if (not res) ;; tt:send-receive telling us that communication failed
		 (let* ((host    (tt-conn-host conn))
			(port    (tt-conn-port conn))







>
>
>







331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
		  (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1))
                  (debug:print 0 *default-log-port* errmsg)
		  (thread-sleep! dly)
		  (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)))
	       ((loaded)
		(debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.")
		(tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn))

		;; this would be a good place to force reconnection and connect to a different server
		
		result) ;; (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe))
	       (else
		result)))
	    (else ;; did not receive properly formated result
	     (if (not res) ;; tt:send-receive telling us that communication failed
		 (let* ((host    (tt-conn-host conn))
			(port    (tt-conn-port conn))
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
		   ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe)
		   )))))
	(begin
	  (thread-sleep! 1) ;; no conn yet set up, give it a rest and try again
	  (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)))))

;; gets server info and appends path to server file
;; sorts by age, oldest first
;;
;; returns list of (host port startseconds server-id servinfofile)
;;
(define (tt:get-server-info-sorted ttdat dbfname)
  (let* ((areapath (tt-areapath ttdat))
	 (sfiles   (tt:find-server areapath dbfname))
	 (sdats    (filter car (map tt:server-get-info sfiles))) ;; first element is #f if the file disappeared while being read
	 (sorted   (sort sdats (lambda (a b)
				 (let* ((starta (list-ref a 2))
					(startb (list-ref b 2)))
				   (if (eq? starta startb)
				       (string>? (list-ref a 3)(list-ref b 3)) ;; if servers started at same time look at server-id
				       (< starta startb))))))
	 (count    0))
    (for-each
     (lambda (rec)
       (if (or (> (length sorted) 1)
	       (common:low-noise-print 120 "server info sorted"))
	   (debug:print 2 *default-log-port* "SERVER #"count": "(string-intersperse (map conc sorted) ", ")))
       (set! count (+ count 1)))







|












|







384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
		   ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe)
		   )))))
	(begin
	  (thread-sleep! 1) ;; no conn yet set up, give it a rest and try again
	  (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)))))

;; gets server info and appends path to server file
;; sorts by age, --oldest-- now newest first
;;
;; returns list of (host port startseconds server-id servinfofile)
;;
(define (tt:get-server-info-sorted ttdat dbfname)
  (let* ((areapath (tt-areapath ttdat))
	 (sfiles   (tt:find-server areapath dbfname))
	 (sdats    (filter car (map tt:server-get-info sfiles))) ;; first element is #f if the file disappeared while being read
	 (sorted   (sort sdats (lambda (a b)
				 (let* ((starta (list-ref a 2))
					(startb (list-ref b 2)))
				   (if (eq? starta startb)
				       (string>? (list-ref a 3)(list-ref b 3)) ;; if servers started at same time look at server-id
				       (> starta startb))))))
	 (count    0))
    (for-each
     (lambda (rec)
       (if (or (> (length sorted) 1)
	       (common:low-noise-print 120 "server info sorted"))
	   (debug:print 2 *default-log-port* "SERVER #"count": "(string-intersperse (map conc sorted) ", ")))
       (set! count (+ count 1)))
516
517
518
519
520
521
522


523
524
525
526
527
528
529

;;======================================================================
;; server
;;======================================================================

(define (tt:sync-dbs ttdat)
  #f)



;; start the listener and start responding to requests
;;
;; NOTE: organise by dbfname, not run-id so we don't need
;;       to pull in more modules
;;
;; This is the routine called in megatest.scm to start a server. NOTE: sequence is different for main.db vs. X.db







>
>







520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535

;;======================================================================
;; server
;;======================================================================

(define (tt:sync-dbs ttdat)
  #f)

(define *server-start-requests* '())

;; start the listener and start responding to requests
;;
;; NOTE: organise by dbfname, not run-id so we don't need
;;       to pull in more modules
;;
;; This is the routine called in megatest.scm to start a server. NOTE: sequence is different for main.db vs. X.db
571
572
573
574
575
576
577
578
579


580
581
582

583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
				     (same-host (or (not prime-host) ;; i.e. this is the first host
						    (equal? prime-host host)))
				     (keep-srv  (and good-ping same-host)))
				(if keep-srv	
				    (loop (cdr servrs)
					  host
					  (cons servdat result))
				    (begin
                                      ;; (debug:print-info 0 *default-log-port* "good-ping: " good-ping " same-host: " same-host "keep-srv: " keep-srv)


				      (handle-exceptions
				       exn
				       (debug:print-info 0 *default-log-port* "Error removing server info file: "servinfofile", "

							 (condition->list exn))
				       (delete-file* servinfofile))
				      (loop (cdr servrs) prime-host result)))))
			     (else
			      ;; can't delete it as we don't have a filename. NOTE: Should really never get here.
			      (debug:print-info 0 *default-log-port* "ERROR: bad servinfo record \""servdat"\"")
			      (loop (cdr servrs) prime-host result)) ;; drop 
			     )))))
	       (home-host (if (null? good-srvrs)
			      #f
			      (caar good-srvrs))))
	  ;; by here we have a trustworthy list of servers and we have removed the .servinfo file for any unresponsive servers
	  ;; and the list is in good-srvrs
	  (cond
	   ((not home-host) ;; no servers yet, go ahead and start
	    (debug:print-info 0 *default-log-port* "No servers yet, starting on "(get-host-name)))
	   ((> (length good-srvrs) 2) ;; don't need more, just exit
	    (debug:print-info 0 *default-log-port* "Have "(length good-srvrs)", no need for more, exiting.")
	    (exit))
	   ((not (equal? home-host (get-host-name))) ;; there is a home-host and we are not on it
	    (debug:print-info 0 *default-log-port* "Prime main server is on host "home-host", but we are on host "(get-host-name)", exiting.")
	    (exit))
	   (else
	    (debug:print-info 0 *default-log-port* "Starting on host "(get-host-name)", along with "(length good-srvrs)" other servers.")))







|
|
>
>
|
|
|
>
|
|
|

|











|







577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
				     (same-host (or (not prime-host) ;; i.e. this is the first host
						    (equal? prime-host host)))
				     (keep-srv  (and good-ping same-host)))
				(if keep-srv	
				    (loop (cdr servrs)
					  host
					  (cons servdat result))
				    (let* ((modtime (file-modification-time servinfofile)))
				      ;; if the .servinfo hasn't been touched in five min
				      ;; we can be pretty sure the server is truly dead
				      (if (> (- (current-seconds) modtime) 360)
					  (handle-exceptions
					   exn
					   (debug:print-info 0 *default-log-port*
							     "Error removing server info file: "servinfofile", "
							     (condition->list exn))
					   (delete-file* servinfofile))
					  (loop (cdr servrs) prime-host result))))))
			     (else
			      ;; can't delete it as we don't have a filename. NOTE: Should never get here.
			      (debug:print-info 0 *default-log-port* "ERROR: bad servinfo record \""servdat"\"")
			      (loop (cdr servrs) prime-host result)) ;; drop 
			     )))))
	       (home-host (if (null? good-srvrs)
			      #f
			      (caar good-srvrs))))
	  ;; by here we have a trustworthy list of servers and we have removed the .servinfo file for any unresponsive servers
	  ;; and the list is in good-srvrs
	  (cond
	   ((not home-host) ;; no servers yet, go ahead and start
	    (debug:print-info 0 *default-log-port* "No servers yet, starting on "(get-host-name)))
	   ((> (length good-srvrs) 3) ;; don't need more, just exit
	    (debug:print-info 0 *default-log-port* "Have "(length good-srvrs)", no need for more, exiting.")
	    (exit))
	   ((not (equal? home-host (get-host-name))) ;; there is a home-host and we are not on it
	    (debug:print-info 0 *default-log-port* "Prime main server is on host "home-host", but we are on host "(get-host-name)", exiting.")
	    (exit))
	   (else
	    (debug:print-info 0 *default-log-port* "Starting on host "(get-host-name)", along with "(length good-srvrs)" other servers.")))
620
621
622
623
624
625
626


627
628
629
630
631
632
633
		      (thread-sleep! 0.25)
		      (loop (+ count 1)))
		    (begin
		      (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set! Exiting.")
		      (exit)))))
	  
	  ;; create a servinfo file start keep-running


          (debug:print 0 *default-log-port* "Creating servinfo file for " dbfname)
	  (tt:create-server-registration-file ttdat dbfname)
	  (procinf-status-set! *procinf* "running")
	  (tt-state-set! ttdat 'running)
	  (dbfile:with-no-sync-db
	   nosyncdbpath
	   (lambda (nsdb)







>
>







629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
		      (thread-sleep! 0.25)
		      (loop (+ count 1)))
		    (begin
		      (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set! Exiting.")
		      (exit)))))
	  
	  ;; create a servinfo file start keep-running
	  ;; On WSL there seems to be a race condition where the .servinfo file
	  ;; is not created fast enough
          (debug:print 0 *default-log-port* "Creating servinfo file for " dbfname)
	  (tt:create-server-registration-file ttdat dbfname)
	  (procinf-status-set! *procinf* "running")
	  (tt-state-set! ttdat 'running)
	  (dbfile:with-no-sync-db
	   nosyncdbpath
	   (lambda (nsdb)
646
647
648
649
650
651
652


653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668



669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
	   nosyncdbpath
	   (lambda (nsdb)
	     (dbfile:insert-or-update-process nsdb *procinf*)))
	  (debug:print 0 *default-log-port* "Exiting now.")
	  (exit))))))

(define (tt:keep-running ttdat dbfname dbstruct)


  
  ;; at this point the server is running and responding to calls, we just monitor
  ;; for db calls and exit if there are none.

  ;; if I am not in the first 3 servers, exit
  (let* ((start-time (current-seconds)))
    (let loop ()
      (let* ((servers   (tt:get-server-info-sorted ttdat dbfname))
	     (home-host (if (null? servers)
			    #f
			    (caar servers)))
	     (my-index  (list-index (lambda (x)
				      (equal? (list-ref x 6)
					      (tt-servinf-file ttdat)))
				    servers))
	     (ok         (cond



			  ((not *server-run*)
			   (debug:print 0 *default-log-port* "WARNING: received a stop server from client by remote request.")
			   #f)
			  ((null? servers)
			   (debug:print 0 *default-log-port* "WARNING: no servinfo files found, this cannot be.")
			   #f) ;; not ok
			  ((> my-index 2)
			   (debug:print 0 *default-log-port* "WARNING: there are more than two servers ahead of me, I'm not needed, exiting.")
			   #f) ;; not ok to not be in first three
			  ((eq? (tt-state ttdat) 'running) #t) ;; we are good to keep going
			  ((> (- (current-seconds) start-time) 30)
			   (debug:print 0 *default-log-port* "WARNING: over 30 seconds and not yet in runnning mode. Exiting.")
			   #f)
			  (else #t))))
	(if ok







>
>
















>
>
>






|
|







657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
	   nosyncdbpath
	   (lambda (nsdb)
	     (dbfile:insert-or-update-process nsdb *procinf*)))
	  (debug:print 0 *default-log-port* "Exiting now.")
	  (exit))))))

(define (tt:keep-running ttdat dbfname dbstruct)

  (thread-sleep! 1)
  
  ;; at this point the server is running and responding to calls, we just monitor
  ;; for db calls and exit if there are none.

  ;; if I am not in the first 3 servers, exit
  (let* ((start-time (current-seconds)))
    (let loop ()
      (let* ((servers   (tt:get-server-info-sorted ttdat dbfname))
	     (home-host (if (null? servers)
			    #f
			    (caar servers)))
	     (my-index  (list-index (lambda (x)
				      (equal? (list-ref x 6)
					      (tt-servinf-file ttdat)))
				    servers))
	     (ok         (cond
			  ((not my-index)
			   (debug:print 0 *default-log-port* "WARNING: Apparently I don't exist.")
			   #f) ;; keep trying or give up?
			  ((not *server-run*)
			   (debug:print 0 *default-log-port* "WARNING: received a stop server from client by remote request.")
			   #f)
			  ((null? servers)
			   (debug:print 0 *default-log-port* "WARNING: no servinfo files found, this cannot be.")
			   #f) ;; not ok
			  ((> my-index 3)
			   (debug:print 0 *default-log-port* "WARNING: there are more than three servers ahead of me, I'm not needed, exiting.")
			   #f) ;; not ok to not be in first three
			  ((eq? (tt-state ttdat) 'running) #t) ;; we are good to keep going
			  ((> (- (current-seconds) start-time) 30)
			   (debug:print 0 *default-log-port* "WARNING: over 30 seconds and not yet in runnning mode. Exiting.")
			   #f)
			  (else #t))))
	(if ok
694
695
696
697
698
699
700






701


702
703
704
705
706
707
708
	      (let* ((sinfo-file (tt-servinf-file ttdat)))
		;; (debug:print 0 *default-log-port* "INFO: touching "sinfo-file)
		(set! (file-modification-time sinfo-file) (current-seconds))
		((dbr:dbstruct-sync-proc dbstruct) last-update)
		(dbr:dbstruct-last-update-set! dbstruct curr-secs))))
	
	(if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param))






	    (begin


	      (thread-sleep! 5)
	      (loop)))))
    (tt:shutdown-server ttdat)
    (debug:print 0 *default-log-port* "INFO: Server timed out, exiting from tt:keep-running.")))


(define (tt:shutdown-server ttdat)







>
>
>
>
>
>
|
>
>







710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
	      (let* ((sinfo-file (tt-servinf-file ttdat)))
		;; (debug:print 0 *default-log-port* "INFO: touching "sinfo-file)
		(set! (file-modification-time sinfo-file) (current-seconds))
		((dbr:dbstruct-sync-proc dbstruct) last-update)
		(dbr:dbstruct-last-update-set! dbstruct curr-secs))))
	
	(if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param))
	    ;; process any requests to start a new server due to load on this one
	    (let* ((requests *server-start-requests*))
	      (set! *server-start-requests* '())
	      (if (> (length requests) 0)
		  (debug:print-info 0 *default-log-port* "Processing "(length requests)" server start requests"))
	      (for-each (lambda (proc)
			  (proc)
			  (thread-sleep! 1))
			requests)
	      (thread-sleep! 5)
	      (loop)))))
    (tt:shutdown-server ttdat)
    (debug:print 0 *default-log-port* "INFO: Server timed out, exiting from tt:keep-running.")))


(define (tt:shutdown-server ttdat)
726
727
728
729
730
731
732







733
734
735
736
737
738
739
740
	 (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
	 (serv-id (tt:mk-signature areapath)))
    (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
    (tt-servinf-file-set! ttdat servinf)
    (with-output-to-file servinf
      (lambda ()
	(print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname)))







      serv-id))

;; find valid server
;; get servers listed, last part of name must match :<dbfname>
;; if more than one, wait one second and look again
;; future: ping oldest, if alive remove other :<dbfname> files
;;
(define (tt:find-server areapath dbfname)







>
>
>
>
>
>
>
|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
	 (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
	 (serv-id (tt:mk-signature areapath)))
    (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
    (tt-servinf-file-set! ttdat servinf)
    (with-output-to-file servinf
      (lambda ()
	(print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname)))
    (let loop ((count 0))
      (if (not (file-exists? servinf))
	  (begin
	    (debug:print 0 *default-log-port* "WARNING: file "servinf" was created but it doesn't show up on disk! We'll try again.")
	    (thread-sleep! 1)
	    (if (< count 10)
		(loop (+ count 1))))))
    serv-id))

;; find valid server
;; get servers listed, last part of name must match :<dbfname>
;; if more than one, wait one second and look again
;; future: ping oldest, if alive remove other :<dbfname> files
;;
(define (tt:find-server areapath dbfname)
800
801
802
803
804
805
806


807
808
809
810
811
812
813
814
815
816
817
818

819
820
821
822
823
824

825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841

(define *last-server-start* (make-hash-table))

(define (tt:too-recent-server-start dbfname)
  (let* ((last-run-time (hash-table-ref/default *last-server-start* dbfname #f)))
    (and last-run-time
	 (< (- (current-seconds) last-run-time) 5))))


    
;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
;; if the target-host is set 
;; try running on that host
;;   incidental: rotate logs in logs/ dir.
;;
(define  (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
  (assert areapath  "FATAL: tt:server-process-run called without areapath defined.")
  (assert testsuite "FATAL: tt:server-process-run called without testsuite defined.")
  (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)))

    (if (tt:too-recent-server-start dbfname)
	#f
	(let* ((load     (get-normalized-cpu-load))
	       (srvrs    (tt:find-server areapath dbfname))
	       (trying   (length srvrs))
	       (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. Please reduce the load on "(get-host-name)" by killing some processes")
	    (thread-sleep! 1)
	    #f)
	   ((> nrun 100)
	    (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
	    (thread-sleep! 1)
	    #f)
	   ((> trying 2)
	    (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.")
	    (thread-sleep! 1)
	    #f)
	   (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"))







>
>












>
|





>

|
|
|





|







831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876

(define *last-server-start* (make-hash-table))

(define (tt:too-recent-server-start dbfname)
  (let* ((last-run-time (hash-table-ref/default *last-server-start* dbfname #f)))
    (and last-run-time
	 (< (- (current-seconds) last-run-time) 5))))

(define *last-server-start-request-time* 0)
    
;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
;; if the target-host is set 
;; try running on that host
;;   incidental: rotate logs in logs/ dir.
;;
(define  (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
  (assert areapath  "FATAL: tt:server-process-run called without areapath defined.")
  (assert testsuite "FATAL: tt:server-process-run called without testsuite defined.")
  (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)))
    (if (or (< (- (current-seconds) *last-server-start-request-time*) 5) ;; attempted start less than 5 sec ago
	    (tt:too-recent-server-start dbfname))
	#f
	(let* ((load     (get-normalized-cpu-load))
	       (srvrs    (tt:find-server areapath dbfname))
	       (trying   (length srvrs))
	       (nrun     (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
	  (set! *last-server-start-request-time* (current-seconds))
	  (cond
	   ((> load 4.0)
	    (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 4.0. Not starting a server. Please reduce the load on "(get-host-name)" by killing some processes")
	    (thread-sleep! 1) ;; I'm not convinced that a delay here is helpful. -mrw-
	    #f)
	   ((> nrun 100)
	    (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
	    (thread-sleep! 1)
	    #f)
	   ((> trying 3)
	    (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.")
	    (thread-sleep! 1)
	    #f)
	   (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"))