Megatest

Check-in [c1bbcec340]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Don't start servers if not on the host selected for home or there are more than 20 servers running
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: c1bbcec340f1588c77dd9d2a5ceca5e39c24892d
User & Date: matt on 2022-12-10 21:42:37
Other Links: branch diff | manifest | tags
Context
2022-12-11
10:22
Added periodic sync from mtrah area into tmp area to reduce chances of an issue from servers running from more than one host if NFS is super slow. check-in: e9d6ea9e8d user: matt tags: v1.80
2022-12-10
21:42
Don't start servers if not on the host selected for home or there are more than 20 servers running check-in: c1bbcec340 user: matt tags: v1.80
2022-12-08
20:57
Changed mt version to 1.8002. check-in: 1160944815 user: mmgraham tags: v1.80, v1.8002
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dbfile.scm from [d6dced8a5a] to [13bb136850].

︙
991
992
993
994
995
996
997

998
999
1000
1001
1002
1003
1004

991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005








+









(define dbfile:db-init-proc (make-parameter #f))

;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
  (assert dbstruct "FATAL: db:with-db called with dbstruct "#f)
  (let* ((use-mutex (> *api-process-request-count* 25)) ;; risk of db corruption
	 (have-struct (dbr:dbstruct? dbstruct))
         (dbdat     (if have-struct                ;; this stuff just allows us to call with a db handle directly
			(db:open-db dbstruct run-id (dbfile:db-init-proc)) ;; (dbfile:get-subdb dbstruct run-id)
			#f))
	 (db        (if have-struct                ;; this stuff just allows us to call with a db handle directly
			(dbr:dbdat-dbh dbdat)
︙

Modified http-transport.scm from [84bebe0a7c] to [4e52ed5cac].

︙
558
559
560
561
562
563
564
565

566
567
568
569
570
571
572

558
559
560
561
562
563
564

565
566
567
568
569
570
571
572








-
+








		  (current-seconds)))
          (if (common:low-noise-print 120 "server continuing")
              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	      (let ((curr-time (current-seconds)))
		(handle-exceptions
		    exn
		    (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on info file " servinfofile ". Are you out of space on that disk? exn=" exn)
		    (if (and (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter
		    (if (and ;; (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter
			     (not *server-overloaded*)
			     (file-exists? servinfofile))
			(change-file-times servinfofile curr-time curr-time)))
		(if (or (common:low-noise-print 120 "start new server")
			(> *api-process-request-count* 50)) ;; if this server is kind of busy start up another
		    (begin
		      (debug:print-info 0 *default-log-port* "Server is busy, parallel-api-count "*api-process-request-count*", start another if possible...")
︙
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
644

645
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

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
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658








-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+

-
-
-
-
-
-
-
-
-
-
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch)
  ;; check that a server start is in progress, pause or exit if so
  (let* ((tmp-area            (common:get-db-tmp-area))
	 (server-start        (conc tmp-area "/.server-start"))
  ;; check the .servinfo directory, are there other servers running on this
  ;; or another host?
  (let* ((server-start-is-ok  (server:minimal-check *toppath*)))
	 (server-started      (conc tmp-area "/.server-started"))
	 (start-time          (common:lazy-modification-time server-start))
	 (started-time        (common:lazy-modification-time server-started))
	 (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
	 (start-time-old      (> (- (current-seconds) start-time) 5))
         (cleanup-proc        (lambda (msg)
                                (let* ((serv-fname      (conc "server-" (current-process-id) "-" (get-host-name) ".log"))
                                       (full-serv-fname (conc *toppath* "/logs/" serv-fname))
                                       (new-serv-fname  (conc *toppath* "/logs/" "defunct-" serv-fname)))
                                  (debug:print 0 *default-log-port* msg)
                                  (if (common:file-exists? full-serv-fname)
                                      (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname))
                                      (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname))
                                  (exit)))))
    #;(if (and (not start-time-old) ;; last server start try was less than five seconds ago
	     (not server-starting))
    (if (not server-start-is-ok)
	(begin
	  (cleanup-proc "NOT starting server, there is either a recently started server or a server in process of starting")
	  (exit)))
    ;; lets not even bother to start if there are already three or more server files ready to go
    #;(let* ((num-alive   (server:get-num-alive (server:get-list *toppath*))))
      (if (> num-alive 3)
          (begin
            (cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up"))
            (exit))))
    #;(common:save-pkt `((action . start)
		       (T      . server)
	  (debug:print 0 *default-log-port* "ERROR: server start not ok, exiting now.")
	  (exit 1))))
    
  ;; check that a server start is in progress, pause or exit if so
		       (pid    . ,(current-process-id)))
		     *configdat* #t)
    (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")
                                    "-")
                                )) "Server run"))
           (th3 (make-thread (lambda ()
                               (debug:print-info 0 *default-log-port* "Server monitor thread started")
                               (http-transport:keep-running)
                               "Keep running"))))
      (thread-start! th2)
      (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
      (thread-start! th3)
      (set! *didsomething* #t)
      (thread-join! th2)
      (exit))))
  (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")
                                  "-")
                              )) "Server run"))
         (th3 (make-thread (lambda ()
                             (debug:print-info 0 *default-log-port* "Server monitor thread started")
                             (http-transport:keep-running)
                             "Keep running"))))
    (thread-start! th2)
    (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
    (thread-start! th3)
    (set! *didsomething* #t)
    (thread-join! th2)
    (exit)))

;; (define (http-transport:server-signal-handler signum)
;;   (signal-mask! signum)
;;   (handle-exceptions
;;    exn
;;    (debug:print 0 *default-log-port* " ... exiting ...")
;;    (let ((th1 (make-thread (lambda ()
︙

Modified megatest.scm from [89decfdb89] to [81aaa85fa0].

︙
932
933
934
935
936
937
938
939

940
941


942
943
944
945
946
947
948

932
933
934
935
936
937
938

939


940
941
942
943
944
945
946
947
948








-
+
-
-
+
+








;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let ((tl        (launch:setup))
    (let ((tl        (launch:setup)))
          (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
      (server:launch 0 transport-type)
      ;; (server:launch 0 'http)
      (http-transport:launch)
      (set! *didsomething* #t)))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (begin
︙

Modified server.scm from [8e8a09693f] to [52fd15527b].

︙
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

63
64
65
66
67
68
69











70
71
72
73
74
75
76








-
-
-
-
-
-
-
-
-
-
-








;;======================================================================
;; S E R V E R
;;======================================================================

;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
  (case transport-type
    ((http)(http-transport:launch))
    ;;((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))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; Get the transport
(define (server:get-transport)
  (if *transport-type*
︙
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145

146
147
148
149
150
151
152

120
121
122
123
124
125
126








127
128
129
130
131
132
133
134








-
-
-
-
-
-
-
-
+









;; 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  (server:run areapath) ;; areapath is *toppath* for a given testsuite area
  (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    (server:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
	 ;; (target-host (car homehost))
	 (testsuite   (common:get-testsuite-name))
  (let* ((testsuite   (common:get-testsuite-name))
	 (logfile     (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
	 (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
			   ""))
	 (cmdln (conc (common:get-megatest-exe)
		      " -server - ";; (or target-host "-")
		      (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
			  " -daemonize "
︙
439
440
441
442
443
444
445


























446
447
448
449
450
451
452
453
454
455
456
457
458
459
460


461
462
463
464
465
466
467

421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+















+
+








		  (hash-table-set! res hostport serverdat)
		  (debug:print-info 0 *default-log-port* "bad server info for "f": "serverdat)))
	     (else
	      (debug:print-info 0 *default-log-port* "bad server info for "f": "serverdat)))))
       allfiles)
      res)))

;; check the .servinfo directory, are there other servers running on this
;; or another host?
;;
;; returns #t => ok to start another server
;;         #f => not ok to start another server
;;
(define (server:minimal-check areapath)
  (server:clean-up-old areapath)
  (let* ((srvdir      (conc areapath"/.servinfo"))
	 (servrs      (glob (conc srvdir"/*")))
	 (thishostip  (server:get-best-guess-address (get-host-name)))
	 (thisservrs  (glob (conc srvdir"/"thishostip":*")))
	 (homehostinf (server:choose-server areapath 'homehost))
	 (havehome    (car homehostinf))
	 (wearehome   (cdr homehostinf)))
    (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
		      ", numservers: "(length thisservrs))
    (cond
     ((not havehome) #t) ;; no homehost yet, go for it
     ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
     ((and havehome (not wearehome)) #f)     ;; we are not the home host
     ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
     (else
      (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
      #t))))
	 
;; oldest server alive determines host then choose random of youngest
;; five servers on that host
;;
;; mode:
;;   best - get best server (random of newest five)
;;   home - get home host based on oldest server
;;   info - print info
(define (server:choose-server areapath #!optional (mode 'best))
  ;; age is current-starttime
  ;; find oldest alive
  ;;   1. sort by age ascending and ping until good
  ;; find alive rand from youngest
  ;;   1. sort by age descending
  ;;   2. take five
  ;;   3. check alive, discard if not and repeat
  ;; first we clean up old server files
  (server:clean-up-old areapath)
  (let* ((serversdat  (server:get-servers-info areapath))
	 (servkeys    (hash-table-keys serversdat))
	 (by-time-asc (if (not (null? servkeys))
			  (sort servkeys ;; list of "host:port"
				(lambda (a b)
				  (>= (list-ref (hash-table-ref serversdat a) 2)
				      (list-ref (hash-table-ref serversdat b) 2))))
︙
504
505
506
507
508
509
510






















511
512
513
514
515
516
517

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








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	     #f)))
	(begin
	  (server:run areapath)
	  (thread-sleep! 3)
	  (case mode
	    ((homehost) (cons #f #f))
	    (else	#f))))))

(define (server:clean-up-old areapath)
  ;; any server file that has not been touched in ten minutes is effectively dead
  (let* ((sfiles (glob (conc areapath"/.servinfo/*"))))
    (for-each
     (lambda (sfile)
       (let* ((modtime (handle-exceptions
			   exn
			 (begin
			   (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile)
			   (current-seconds))
			 (file-modification-time sfile))))
	 (if (and (number? modtime)
		  (> (- (current-seconds) modtime)
		     600))
	     (begin
	       (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
	       (handle-exceptions
		   exn
		 (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
		 (delete-file sfile))))))
     sfiles)))

;; would like to eventually get rid of this
;;
(define (common:on-homehost?)
  (server:choose-server *toppath* 'home?))

;; kind start up of server, wait before allowing another server for a given
︙

This page was generated in about 0.175s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00