Megatest

Changes On Branch 3d418034bd478cec
Login

Changes In Branch v1.63-server-fix Through [3d418034bd] Excluding Merge-Ins

This is equivalent to a diff from 88034605c0 to 3d418034bd

2017-01-03
10:50
Commented out a call to BB> that seemed to have trouble ... check-in: e26b0892dd user: mrwellan tags: v1.63
2016-12-29
15:16
fixed bug with kind-run call Closed-Leaf check-in: 2148615256 user: bjbarcla tags: v1.63-server-fix
00:14
added script manyservers.sh which will be basis for a test of server start & collision resilency check-in: 3d418034bd user: bjbarcla tags: v1.63-server-fix
00:11
updated server launch to handle collisions gracefully (but introduced other issues - moving to sidebranch to debug) check-in: c9880665a8 user: bjbarcla tags: v1.63-server-fix
2016-12-28
17:22
Automated merge of v1.63/88034605c0/integ into integ-home check-in: fd7a37d790 user: matt tags: integ-home
16:35
fixed condition where watchdog continued to process many times rapidly when time-to-exit is #t check-in: 88034605c0 user: bjbarcla tags: v1.63
2016-12-27
17:15
improved server stability check-in: 6b5c7789cb user: bjbarcla tags: v1.63

Modified common.scm from [d2df0eaa3f] to [4b29489636].

577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
        (this-wd-num     (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
        )
    (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num)
    (if (and legacy-sync (not *time-to-exit*))
	(let ((dbstruct (db:setup)))
	  (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
	  (let loop ()
            (BB> "watchdog loop.  pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
	    ;; sync for filesystem local db writes
	    ;;
	    (mutex-lock! *db-multi-sync-mutex*)
	    (let* ((need-sync        (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
		   (sync-in-progress *db-sync-in-progress*)
		   (should-sync      (and (not *time-to-exit*)
                                          (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum







|







577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
        (this-wd-num     (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
        )
    (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num)
    (if (and legacy-sync (not *time-to-exit*))
	(let ((dbstruct (db:setup)))
	  (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
	  (let loop ()
            ;;(BB> "watchdog loop.  pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
	    ;; sync for filesystem local db writes
	    ;;
	    (mutex-lock! *db-multi-sync-mutex*)
	    (let* ((need-sync        (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
		   (sync-in-progress *db-sync-in-progress*)
		   (should-sync      (and (not *time-to-exit*)
                                          (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635

636
637
638
639
640
641
642
		    (set! last-time start-time)
		    (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	    
	    ;; keep going unless time to exit
	    ;;
	    (if (not *time-to-exit*)
		(let delay-loop ((count 0))
                  (BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
                                                            
		  (if (and (not *time-to-exit*)
			   (< count 4)) ;; was 11, changing to 4. 
		      (begin
			(thread-sleep! 1)
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))

(define (std-exit-procedure)
  (on-exit (lambda () 0))

  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))







|












>







616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
		    (set! last-time start-time)
		    (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	    
	    ;; keep going unless time to exit
	    ;;
	    (if (not *time-to-exit*)
		(let delay-loop ((count 0))
                  ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
                                                            
		  (if (and (not *time-to-exit*)
			   (< count 4)) ;; was 11, changing to 4. 
		      (begin
			(thread-sleep! 1)
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))

(define (std-exit-procedure)
  (on-exit (lambda () 0))
  ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))
675
676
677
678
679
680
681

682
683
684
685
686
687
688
    )

  0)

(define (std-signal-handler signum)
  ;; (signal-mask! signum)
  (set! *time-to-exit* #t)

  (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
  (exit))

(set-signal-handler! signal/int  std-signal-handler)  ;; ^C
(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!







>







676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
    )

  0)

(define (std-signal-handler signum)
  ;; (signal-mask! signum)
  (set! *time-to-exit* #t)
  ;;(BB> "got signal "signum)
  (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
  (exit))

(set-signal-handler! signal/int  std-signal-handler)  ;; ^C
(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!

Modified common_records.scm from [4d93fb5556] to [e3400966c5].

119
120
121
122
123
124
125

126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))

;; Brandon's debug printer shortcut (indulge me :)

(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location #f))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (this-func (cadr (string-split this-loc " "))))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let ((dp-args (append (list 0 *default-log-port* location"   "  ) in-args)))
      (apply debug:print dp-args))))

(define *BBpp_custom_expanders_list* (make-hash-table))



;; register hash tables with BBpp.







>










|







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))

;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location #f))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (this-func (cadr (string-split this-loc " "))))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let ((dp-args (append (list 0 *default-log-port* (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)"   ")  ) in-args)))
      (apply debug:print dp-args))))

(define *BBpp_custom_expanders_list* (make-hash-table))



;; register hash tables with BBpp.

Modified http-transport.scm from [285317a3d3] to [85b3cef6fd].

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
408
409
410
411
412
413
414
         (last-access 0)
	 (server-timeout (server:get-timeout))
	 (server-going  #f))
    (let loop ((count         0)
	       (server-state 'available)
	       (bad-sync-count 0)
	       (start-time     (current-milliseconds)))

      ;; Use this opportunity to sync the tmp db to megatest.db
      (if (not server-going) ;; *dbstruct-db* 
	    ;; Removed code is pasted below (keeping it around until we are clear it is not needed).
	    ;; no *dbstruct-db* yet, set running after our first pass through and start the db
	    (if (eq? server-state 'available)
		(let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
		  (if (equal? new-server-id server-id)
		      (begin
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")

			(thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
			(set! *dbstruct-db*  (db:setup)) ;;  run-id))
			(set! server-going #t)
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")

			(server:write-dotserver *toppath* (conc iface ":" port))

			(delete-file* (conc *toppath* "/.starting-server")))
		      (begin ;; gotta exit nicely

			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
			(http-transport:server-shutdown server-id port))))))

      ;; when things go wrong we don't want to be doing the various queries too often
      ;; so we strive to run this stuff only every four seconds or so.
      (let* ((sync-time (- (current-milliseconds) start-time))
	    (rem-time  (quotient (- 4000 sync-time) 1000)))
	(if (and (<= rem-time 4)
		 (>  rem-time 0))
	    (thread-sleep! rem-time)))







|









>




>

>
|

>


|







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
408
409
410
411
412
413
414
415
416
417
418
         (last-access 0)
	 (server-timeout (server:get-timeout))
	 (server-going  #f))
    (let loop ((count         0)
	       (server-state 'available)
	       (bad-sync-count 0)
	       (start-time     (current-milliseconds)))
      ;;(BB> "http-transport: top of loop; count="count" server-state="server-state" bad-sync-count="bad-sync-count" server-going="server-going)
      ;; Use this opportunity to sync the tmp db to megatest.db
      (if (not server-going) ;; *dbstruct-db* 
	    ;; Removed code is pasted below (keeping it around until we are clear it is not needed).
	    ;; no *dbstruct-db* yet, set running after our first pass through and start the db
	    (if (eq? server-state 'available)
		(let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
		  (if (equal? new-server-id server-id)
		      (begin
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
                        ;;(BB> "http-transport: ->dbprep")
			(thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
			(set! *dbstruct-db*  (db:setup)) ;;  run-id))
			(set! server-going #t)
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
                        ;;(BB> "http-transport: ->running")
			(server:write-dotserver *toppath* (conc iface ":" port))
                        (thread-start! *watchdog*)
                        (server:complete-attempt *toppath*))
		      (begin ;; gotta exit nicely
                        ;;(BB> "http-transport: ->collision")
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
			(http-transport:server-shutdown server-id port))))))
      
      ;; when things go wrong we don't want to be doing the various queries too often
      ;; so we strive to run this stuff only every four seconds or so.
      (let* ((sync-time (- (current-milliseconds) start-time))
	    (rem-time  (quotient (- 4000 sync-time) 1000)))
	(if (and (<= rem-time 4)
		 (>  rem-time 0))
	    (thread-sleep! rem-time)))
484
485
486
487
488
489
490

491
492
493
494
495
496
497
;; (if (and (<= rem-time 4)
;; 	     (> rem-time 0))
;; 	(thread-sleep! rem-time)
;; 	(thread-sleep! 4))) ;; fallback for if the math is changed ...

(define (http-transport:server-shutdown server-id port)
  (let ((tdbdat (tasks:open-db)))

    (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
    ;;
    ;; start_shutdown
    ;;
    (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
    (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
    (portlogger:open-run-close portlogger:set-port port "released")







>







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
;; (if (and (<= rem-time 4)
;; 	     (> rem-time 0))
;; 	(thread-sleep! rem-time)
;; 	(thread-sleep! 4))) ;; fallback for if the math is changed ...

(define (http-transport:server-shutdown server-id port)
  (let ((tdbdat (tasks:open-db)))
    ;;(BB> "http-transport:server-shutdown called")
    (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
    ;;
    ;; start_shutdown
    ;;
    (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
    (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
    (portlogger:open-run-close portlogger:set-port port "released")
511
512
513
514
515
516
517

518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
			  (/ *total-non-write-delay* 
			     *number-non-write-queries*))
		      " ms")
    (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
    (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
    ;; if the .server file contained :myport then we can remove it
    (server:remove-dotserver-file *toppath* port)

    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch run-id)
  (with-output-to-file
      (conc *toppath* "/.starting-server")
    (lambda ()
      (print (current-process-id) " on " (get-host-name))))
  (let* ((tdbdat (tasks:open-db)))
    (set! *run-id*   run-id)
    (if (args:get-arg "-daemonize")
	(begin
	  (daemon:ize)
	  (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
	      (begin
		(current-error-port *alt-log-file*)
		(current-output-port *alt-log-file*)))))
    (if (and (server:read-dotserver *toppath*)
             (server:check-if-running run-id))
	(begin
	  (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
	  (exit 0))
	(begin ;; ok, no server detected, clean out any lingering records
	   (tasks:server-force-clean-running-records-for-run-id  (db:delay-if-busy tdbdat) run-id "notresponding")))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
		      (- remtries 1)))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		(delete-file* (conc *toppath* "/.starting-server"))
		))
	  (let* ((th2 (make-thread (lambda ()
				     (debug:print-info 0 *default-log-port* "Server run thread started")
				     (http-transport:run 
				      (if (args:get-arg "-server")
					  (args:get-arg "-server")
					  "-")







>







<
|
<
<















|












|







516
517
518
519
520
521
522
523
524
525
526
527
528
529
530

531


532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
			  (/ *total-non-write-delay* 
			     *number-non-write-queries*))
		      " ms")
    (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
    (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
    ;; if the .server file contained :myport then we can remove it
    (server:remove-dotserver-file *toppath* port)
    ;;(BB> "http-transport:server-shutdown -> exit")
    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch run-id)

  (server:attempting-start *toppath*)


  (let* ((tdbdat (tasks:open-db)))
    (set! *run-id*   run-id)
    (if (args:get-arg "-daemonize")
	(begin
	  (daemon:ize)
	  (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
	      (begin
		(current-error-port *alt-log-file*)
		(current-output-port *alt-log-file*)))))
    (if (and (server:read-dotserver *toppath*)
             (server:check-if-running run-id))
	(begin
	  (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
	  (exit 0))
	(begin ;; ok, no server detected, clean out any lingering records
          (tasks:server-force-clean-running-records-for-run-id  (db:delay-if-busy tdbdat) run-id "notresponding")))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
		      (- remtries 1)))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
                (server:complete-attempt *toppath*)
		))
	  (let* ((th2 (make-thread (lambda ()
				     (debug:print-info 0 *default-log-port* "Server run thread started")
				     (http-transport:run 
				      (if (args:get-arg "-server")
					  (args:get-arg "-server")
					  "-")

Modified megatest.scm from [db4e22b0be] to [ba3fdf979e].

347
348
349
350
351
352
353

354
355

356
357
358
359
360
361
362
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog* (make-thread common:watchdog "Watchdog thread"))


(thread-start! *watchdog*)
(BB> "thread-start! watchdog")

(if (args:get-arg "-log")
    (let ((oup (open-output-file (args:get-arg "-log"))))
      (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
      (set! *default-log-port* oup)))

(if (or (args:get-arg "-h")
	(args:get-arg "-help")







>
|
|
>







347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog* (make-thread common:watchdog "Watchdog thread"))

(if (not (args:get-arg "-server"))
    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
;;(BB> "thread-start! watchdog")

(if (args:get-arg "-log")
    (let ((oup (open-output-file (args:get-arg "-log"))))
      (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
      (set! *default-log-port* oup)))

(if (or (args:get-arg "-h")
	(args:get-arg "-help")
1988
1989
1990
1991
1992
1993
1994
1995






1996

1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008

;;======================================================================
;; Exit and clean up
;;======================================================================

(if (not *didsomething*)
    (debug:print 0 *default-log-port* help))
(BB> "thread-join! watchdog")






(thread-join! *watchdog*)

(set! *time-to-exit* #t)

(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (exit 0))
        (case *globalexitstatus*
         ((0)(exit 0))
         ((1)(exit 1))
         ((2)(exit 2))
         (else (exit 3)))))







|
>
>
>
>
>
>
|
>












1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017

;;======================================================================
;; Exit and clean up
;;======================================================================

(if (not *didsomething*)
    (debug:print 0 *default-log-port* help))
;;(BB> "thread-join! watchdog")

;; join the watchdog thread if it has been thread-start!ed  (it may not have been started in the case of a server that never enters running state)
;;   (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
(if (thread? *watchdog*)
    (case (thread-state *watchdog*)
      ((ready running blocked sleeping terminated dead)
       (thread-join! *watchdog*))))

(set! *time-to-exit* #t)

(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (exit 0))
        (case *globalexitstatus*
         ((0)(exit 0))
         ((1)(exit 1))
         ((2)(exit 2))
         (else (exit 3)))))

Added minimal/manyservers.sh version [ab71c989a2].















































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
#!/bin/bash

echo manyservers.sh pid $$

logdir=log-manysrv


function reset {
    rm -f .homehost .server .server.lock links/.db/monitor.db .starting-server
    }

function launch_many_servers {
    # count  = $1
    # logdir = $2
    # prefx  = $3
  perl -e 'foreach my $i (1 ... '$1'){print "'$2'/'$3'-srv-$i.log\n"}' | \
     xargs -P $1 -n 1 megatest -server - -run-id 0 -daemonize -log
}

    
function get_srv_pids {
    ps auwx | grep "mtest -server" | grep $logdir | grep -v grep | awk '{print $2}' 
}


if [[ -e $logdir ]]; then rm -rf $logdir; fi
if [[ ! -e $logdir ]]; then mkdir $logdir; fi

reset

simultaneous_servers=20
server_collision_resolution_delay=15
server_timeout_delay=65

echo "Launching $simultaneous_servers simultaneous servers"
launch_many_servers $simultaneous_servers $logdir "first"
echo "Sleeping $server_collision_resolution_delay seconds to allow new servers to die because one is already running."
sleep $server_collision_resolution_delay

pids=`get_srv_pids`
pids_left=`echo $pids | wc -w`
echo "pids_left=$pids_left"
echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1"
if [[ $pids_left == 1 ]]; then
    echo "All servers but 1 terminated. Still good."
else
    if [[ $pids_left == 0 ]]; then
        echo "All servers died too soon.  Not good. Aborting."
        echo "TEST FAIL"
        exit 1
    else
        echo "Too many servers left.  Not good.  Aborting."
        echo "TEST FAIL"
        echo $pids | xargs kill
        sleep 5
        pids=`get_srv_pids`
        pids_left=`echo $pids | wc -w`
        if [[ ! ( $pids_left == 0 ) ]]; then
            echo $pids | xargs kill -9
        fi
        exit 1
    fi
fi



echo "launching another volley of $simultaneous_servers.  THey should all perish. right away, leaving the one server running."
launch_many_servers $simultaneous_servers $logdir "second"
sleep $server_collision_resolution_delay

pids=`get_srv_pids`
pids_left=`echo $pids | wc -w`
echo "pids_left=$pids_left"
echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1"
if [[ $pids_left == 1 ]]; then
    echo "All servers but 1 terminated. So far so good."
else
    if [[ $pids_left == 0 ]]; then
        echo "All servers died too soon.  Not good. Aborting."
        echo "TEST FAIL"
        exit 1
    else
        echo "Too many servers left.  Not good.  Aborting."
        echo "TEST FAIL"
        echo $pids | xargs kill
        sleep 5
        pids=`get_srv_pids`
        pids_left=`echo $pids | wc -w`
        if [[ ! ( $pids_left == 0 ) ]]; then
            echo $pids | xargs kill -9
        fi
        exit 1
    fi
fi



echo "sleeping for awhile ($server_timeout_delay seconds) to let server exit on its own for no-request timeout"
sleep $server_timeout_delay
pids=`get_srv_pids`
pids_left=`echo $pids | wc -w`
echo "after $server_timeout_delay seconds: servers remaining=$pids_left; expecting 0"

if [[ $pids_left == 0 ]]; then
    echo "No servers remain. This is good."
    echo "TEST PASS"
    exit 0
else
    echo "Too many servers left.  Not good.  Aborting."
    echo "TEST FAIL"
    echo $pids | xargs kill
    sleep 5
    pids=`get_srv_pids`
    pids_left=`echo $pids | wc -w`
    if [[ ! ( $pids_left == 0 ) ]]; then
        echo $pids | xargs kill -9
    fi
    exit 1
fi

Modified server.scm from [c0f30a061c] to [24b58ed32b].

45
46
47
48
49
50
51
52












53
54
55
56
57
58
59
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
  (BB> "server:launch fired for run-id="run-id" transport-type="transport-type)












  (case transport-type
    ((http)(http-transport:launch run-id))
    ;;((nmsg)(nmsg-transport:launch run-id))
    ((rpc)  (rpc-transport:launch run-id))
    (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
;;       (else   (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
;; 	      (rpc-transport:launch run-id)))))







|
>
>
>
>
>
>
>
>
>
>
>
>







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
  ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type)

  (let ((attempt-in-progress (server:start-attempted? *toppath*)))
    (when attempt-in-progress
      (debug:print-info 0 *default-log-port* "Server start attempt in progress in other process (=> "attempt-in-progress"<=).  Aborting server launch attempt in this process ("(current-process-id)")")
      (exit)))
      
  (let ((dotserver-url (server:check-if-running *toppath*)))
    (when dotserver-url
      (debug:print-info 0 *default-log-port* "Server already running (=> "dotserver-url"<=).  Aborting server launch attempt in this process ("(current-process-id)")")
      (exit)
      ))
  
  (case transport-type
    ((http)(http-transport:launch run-id))
    ;;((nmsg)(nmsg-transport:launch run-id))
    ((rpc)  (rpc-transport:launch run-id))
    (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
;;       (else   (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
;; 	      (rpc-transport:launch run-id)))))
103
104
105
106
107
108
109


110
111
112
113
114
115
116
117
118
119
120
121
122
123






124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168









169
170
171
172
173

174
175
176
177





178
179
180
181
182
183
184
;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and the target-host is set 
;; try running on that host
;;   incidental: rotate logs in logs/ dir.
;;
(define  (server:run areapath) ;; areapath is ignored for now.
  (let* ((curr-host   (get-host-name))


	 (curr-ip     (server:get-best-guess-address curr-host))
	 (curr-pid    (current-process-id))
	 (homehost    (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
	 (target-host (car homehost))
	 (testsuite   (common:get-testsuite-name))
	 (logfile     (conc *toppath* "/logs/server.log"))
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
									      (conc " -daemonize -log " logfile)
									      "")
		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")))
    ;; we want the remote server to start in *toppath* so push there
    (push-directory *toppath*)






    (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
    (thread-start! log-rotate)

    ;; host.domain.tld match host?
    (if (and target-host 
	     ;; look at target host, is it host.domain.tld or ip address and does it 
	     ;; match current ip or hostname
	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
	     (not (equal? curr-ip target-host)))
	(begin
	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
	  (setenv "TARGETHOST" target-host)))
    
    (setenv "TARGETHOST_LOGF" logfile)
    (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))

(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run areapath)
  (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f)))
    (if (or (not last-run-time)
	    (> (- (current-seconds) last-run-time) 30))
	(begin
	  (server:run areapath)
	  (hash-table-set! *server-kind-run* areapath (current-seconds))))))

;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;; 
;;  (define (server:try-running run-id)
;;    (if (eq? run-id 0)
;;        (server:run run-id)
;;        (rmt:start-server run-id)))
(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.










(define (server:start-attempted? areapath)
  (let ((flagfile (conc areapath "/.starting-server")))
    (handle-exceptions
     exn
     #f  ;; if things go wrong pretend we can't see the file

     (and (file-exists? flagfile)
	  (< (- (current-seconds)
		(file-modification-time flagfile))
	     15))))) ;; exists and less than 15 seconds old





    
(define (server:read-dotserver areapath)
  (let ((dotfile (conc areapath "/.server")))
    (handle-exceptions
     exn
     #f  ;; if things go wrong pretend we can't see the file
     (if (and (file-exists? dotfile)







>
>





|







|
>
>
>
>
>
>
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



|
|



















>
>
>
>
>
>
>
>
>





>
|
|
|
|
>
>
>
>
>







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and the target-host is set 
;; try running on that host
;;   incidental: rotate logs in logs/ dir.
;;
(define  (server:run areapath) ;; areapath is ignored for now.
  (let* ((curr-host   (get-host-name))
         (attempt-in-progress (server:start-attempted? areapath))
         (dot-server-url (server:check-if-running areapath))
	 (curr-ip     (server:get-best-guess-address curr-host))
	 (curr-pid    (current-process-id))
	 (homehost    (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
	 (target-host (car homehost))
	 (testsuite   (common:get-testsuite-name))
	 (logfile     (conc areapath "/logs/server.log"))
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
									      (conc " -daemonize -log " logfile)
									      "")
		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")))
    ;; we want the remote server to start in *toppath* so push there
    (push-directory areapath)
    (cond
     (attempt-in-progress
      (debug:print 0 *default-log-port* "INFO: Not trying to start server because attempt is in progress: "attempt-in-progress))
     (dot-server-url
            (debug:print 0 *default-log-port* "INFO: Not trying to start server because one is already running : "dot-server-url))
     (else
      (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
      (thread-start! log-rotate)

      ;; host.domain.tld match host?
      (if (and target-host 
               ;; look at target host, is it host.domain.tld or ip address and does it 
               ;; match current ip or hostname
               (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
               (not (equal? curr-ip target-host)))
          (begin
            (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
            (setenv "TARGETHOST" target-host)))
      
      (setenv "TARGETHOST_LOGF" logfile)
      (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
      (system (conc "nbfake " cmdln))
      (unsetenv "TARGETHOST_LOGF")
      (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
      (thread-join! log-rotate)
      (pop-directory)))))
    
(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
        (set! *my-client-signature* sig)
        *my-client-signature*)))

;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run areapath)
  (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f)))
    (if (or (not last-run-time)
	    (> (- (current-seconds) last-run-time) 30))
	(begin
	  (server:run areapath)
	  (hash-table-set! *server-kind-run* areapath (current-seconds))))))

;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;; 
;;  (define (server:try-running run-id)
;;    (if (eq? run-id 0)
;;        (server:run run-id)
;;        (rmt:start-server run-id)))
(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.

(define (server:attempting-start areapath)
  (with-output-to-file
      (conc areapath "/.starting-server")
    (lambda ()
      (print (current-process-id) " on " (get-host-name)))))
  
(define (server:complete-attempt areapath)
  (delete-file* (conc areapath "/.starting-server")))
  
(define (server:start-attempted? areapath)
  (let ((flagfile (conc areapath "/.starting-server")))
    (handle-exceptions
     exn
     #f  ;; if things go wrong pretend we can't see the file
     (cond
      ((and (file-exists? flagfile)
            (< (- (current-seconds)
                  (file-modification-time flagfile))
               15)) ;; exists and less than 15 seconds old
       (with-input-from-file flagfile (lambda () (read-line))))
      ((file-exists? flagfile) ;; it is stale.
       (server:complete-attempt areapath)
       #f)
      (else #f)))))
    
(define (server:read-dotserver areapath)
  (let ((dotfile (conc areapath "/.server")))
    (handle-exceptions
     exn
     #f  ;; if things go wrong pretend we can't see the file
     (if (and (file-exists? dotfile)
229
230
231
232
233
234
235


236
237
238
239
240
241
242
243
    (if dotserver
	(let* ((res (case *transport-type*
		      ((http)(server:ping-server dotserver))
		      ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
		      )))
	  (if res
	      dotserver


	      #f))
	#f)))

;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server.
;;







>
>
|







264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
    (if dotserver
	(let* ((res (case *transport-type*
		      ((http)(server:ping-server dotserver))
		      ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
		      )))
	  (if res
	      dotserver
	      (begin
                (server:remove-dotserver-file areapath ".*") ;; remove stale dotserver
                #f)))
	#f)))

;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server.
;;