Megatest

Check-in [ac69021df7]
Login
Overview
Comment:Partial implementation of homehost-free
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.70-nohomehost
Files: files | file ages | folders
SHA1: ac69021df7fde0b7d93a55c13b99ccf5c17bacd0
User & Date: matt on 2022-11-11 09:42:51
Other Links: branch diff | manifest | tags
Context
2022-11-12
07:03
Steps towards eliminating homehost check-in: a0384d728b user: matt tags: v1.70-nohomehost
2022-11-11
09:42
Partial implementation of homehost-free check-in: ac69021df7 user: matt tags: v1.70-nohomehost
2022-11-10
13:37
Fixed server/client signature. I think. check-in: bf877ecde8 user: matt tags: v1.70
Changes

Modified client.scm from [3f204dd646] to [17a8862d81].

105
106
107
108
109
110
111
112
113

114
115

116
117
118
119
120
121
122
105
106
107
108
109
110
111


112


113
114
115
116
117
118
119
120







-
-
+
-
-
+







		    (set! *runremote* (make-remote))
                    (let* ((server-info (remote-server-info *runremote*))) 
                      (if server-info
                        (begin
                          (remote-server-url-set! *runremote* (server:record->url server-info))
                          (remote-server-id-set! *runremote* (server:record->id server-info)))))))
	      (if (and host port server-id)
		  (let* ((start-res (case *transport-type*
				      ((http)(http-transport:client-connect host port server-id))))
		  (let* ((start-res (http-transport:client-connect host port server-id))
			 (ping-res  (case *transport-type* 
				      ((http)(rmt:login-no-auto-client-setup start-res)))))
			 (ping-res  (rmt:login-no-auto-client-setup start-res)))
		    (if (and start-res
			     ping-res)
			(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
			  (if runremote
			      (begin
				(remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
				(debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))

Modified common.scm from [7a004393e6] to [1861c8c274].

140
141
142
143
144
145
146

147
148
149
150
151
152
153
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154







+







(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f)  ;; used by -log
;; (define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *on-exit-procs* '()) ;; add procs to this list to be executed on exit
(define *default-area-tag* "local")

;; DATABASE
;; (define *dbstruct-dbs*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
3342
3343
3344
3345
3346
3347
3348
3349

3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363

3364
3365
3366
3367
3368
3369
3370
3343
3344
3345
3346
3347
3348
3349

3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372







-
+














+







			(string-split pktsdirs-str " ")
			#f)))
    pktsdirs))

;;======================================================================
;; use-lt is use linktree "lt" link to find pkts dir
(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already
  (if (or add-only
  (if (or (not add-only)
	  (hash-table-exists? *pkts-info* 'last-parent))
      (let* ((parent   (hash-table-ref/default *pkts-info* 'last-parent #f))
	     (pktalist (if parent
			   (cons `(parent . ,parent)
				 pktalist-in)
			   pktalist-in)))
	(let-values (((uuid pkt)
		      (alist->pkt pktalist common:pkts-spec)))
	  (hash-table-set! *pkts-info* 'last-parent uuid)
	  (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
			     (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
				    (pktsdir   (car pktsdirs))) ;; assume it is there
			       (hash-table-set! *pkts-info* 'pkts-dir pktsdir)
			       pktsdir))))
	    (debug:print 0 *default-log-port* "pktsdir: "pktsdir)
            (handle-exceptions
             exn
             (debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!!
             (if (not (file-exists? pktsdir))
                 (create-directory pktsdir #t))
             (with-output-to-file
                 (conc pktsdir "/" uuid ".pkt")

Modified db.scm from [d143149924] to [eca8c190a3].

4584
4585
4586
4587
4588
4589
4590
4591

4592
4593
4594
4595
4596
4597
4598
4599


4600
4601
4602





4603
4604
4605
4606
4607
4608
4609
4584
4585
4586
4587
4588
4589
4590

4591
4592
4593
4594
4595
4596
4597
4598

4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615







-
+







-
+
+



+
+
+
+
+







	       (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) )))) 
))


(define (std-exit-procedure)
  ;;(common:telemetry-log-close)
  (on-exit (lambda () 0))
  (on-exit (lambda () 0)) ;; why is this here?
  ;;(debug:print-info 13 *default-log-port* "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))
    (if (and no-hurry
	     (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
                              (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
			      (if (list? *on-exit-procs*)
				  (for-each
				   (lambda (proc)
				     (proc))
				   *on-exit-procs*))
			      (if *task-db*    
				  (let ((db (cdr *task-db*)))
				    (if (sqlite3:database? db)
					(begin
					  (sqlite3:interrupt! db)
					  (sqlite3:finalize! db #t)
					  ;; (vector-set! *task-db* 0 #f)

Modified http-transport.scm from [d2af089e7c] to [3205da4502].

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
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







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

-
+










-
+
+
+

+
-
+







			  (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if (and sdat
				   (not changed)
				   (> (- (current-seconds) start-time) 2))
			      (let* ((servinfodir (conc *toppath*"/.servinfo"))
				     (ipaddr      (car sdat))
				     (port        (cadr sdat))
				     (servinf     (conc servinfodir"/"ipaddr":"port)))
				(if (not (file-exists? servinfodir))
				    (create-directory servinfodir #t))
				(with-output-to-file servinf
				  (lambda ()
				    (print "SERVER STARTED: "ipaddr":"port" AT "(current-seconds)" server-id: "(server:get-client-signature))
				    (print "started: "(seconds->year-week/day-time (current-seconds)))))
				(set! *on-exit-procs* (cons
						       (lambda ()
			      (begin
							 (delete-file* servinf))
						       *on-exit-procs*))
				;; put data about this server into a simple flat file host.port
				(debug:print-info 0 *default-log-port* "Received server alive signature")
                                (common:save-pkt `((action . alive)
                                #;(common:save-pkt `((action . alive)
                                                   (T      . server)
                                                   (pid    . ,(current-process-id))
                                                   (ipaddr . ,(car sdat))
                                                   (port   . ,(cadr sdat)))
                                                 *configdat* #t)
				sdat)
                              (begin
				(debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
                                (sleep 4)
				(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
				    (begin
				    (let* ((ipaddr  (car sdat))
					   (port    (cadr sdat))
					   (servinf (conc *toppath*"/.servinfo/"ipaddr":"port)))
				      (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
				      ;; (delete-file* servinf) ;; handled by on-exit, can be removed
                                      (common:save-pkt `((action . died)
                                      #;(common:save-pkt `((action . died)
                                                         (T      . server)
                                                         (pid    . ,(current-process-id))
                                                         (ipaddr . ,(car sdat))
                                                         (port   . ,(cadr sdat))
                                                         (msg    . "Transport died?"))
						       *configdat* #t)
				      (exit))
598
599
600
601
602
603
604
605

606
607
608




609
610
611
612
613
614
615
615
616
617
618
619
620
621

622
623
624

625
626
627
628
629
630
631
632
633
634
635







-
+


-
+
+
+
+







    ;; 		      (if (eq? *number-non-write-queries* 0)
    ;; 			  "n/a (no queries)"
    ;; 			  (/ *total-non-write-delay* 
    ;; 			     *number-non-write-queries*))
    ;; 		      " ms")
    
    (db:print-current-query-stats)
    (common:save-pkt `((action . exit)
    #;(common:save-pkt `((action . exit)
                       (T      . server)
                       (pid    . ,(current-process-id)))
                     *configdat* #t)
    *configdat* #t)

    ;; remove .servinfo file(s) here
    
    (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
638
639
640
641
642
643
644
645
646
647
648




649
650
651
652
653
654
655
658
659
660
661
662
663
664




665
666
667
668
669
670
671
672
673
674
675







-
-
-
-
+
+
+
+







	  (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)
		     (pid    . ,(current-process-id)))
		   *configdat* #t)
    #;(common:save-pkt `((action . start)
		       (T      . server)
		       (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"))

Modified server.scm from [b0155e0a8d] to [163356b887].

324
325
326
327
328
329
330


331
332
333
334
335
336
337
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339







+
+







		(lambda (a b)
		  (< (list-ref a 3)
		     (list-ref b 3))))))
    (if (> (length slst) nums)
	(take slst nums)
	slst)))

;; switch from server:get-list to server:get-servers-info
;;
(define (server:get-first-best areapath)
  (let ((srvrs (server:get-best (server:get-list areapath))))
    (if (and srvrs
	     (not (null? srvrs)))
	(car srvrs)
	#f)))

375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
377
378
379
380
381
382
383

384
385
386
387
388
389
390
391







-
+







        *my-client-signature*)))


;; if server-start-last exists, and wasn't old enough, wait <idle time> + 1, then call this function recursively until it is old enough.
;; if it is old enough, overwrite it and wait 0.25 seconds.
;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively.
;;
(define (server:wait-for-server-start-last-flag areapath)
#;(define (server:wait-for-server-start-last-flag areapath)
  (let* ((start-flag (conc areapath "/logs/server-start-last"))
	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
	 (idletime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
	 (server-key (conc (get-host-name) "-" (current-process-id))))
    (if (file-exists? start-flag)
	(let* ((fmodtime (file-modification-time start-flag))
	       (delta    (- (current-seconds) fmodtime))
403
404
405
406
407
408
409














410

























411
412
413
414
415
416
417
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
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







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

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







	       (begin
		 (debug:print-info 0 *default-log-port* "Gating server start, last start: "
				   (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
		 
		 (thread-sleep! ( + 1 idletime))
		 (server:wait-for-server-start-last-flag areapath)))))))

;; oldest server alive determines host then choose random of youngest
;; five servers on that host
;;
(define (server:get-servers-info areapath)
  (let* ((servinfodir (conc *toppath*"/.servinfo"))
	 (allfiles    (glob (conc servinfodir"/*")))
	 (res         (make-hash-table)))
    (for-each
     (lambda (f)
       (let* ((hostport  (pathname-strip-directory f))
	      (serverdat (server:logf-get-start-info f)))
	 (hash-table-set! res hostport serverdat)))
     allfiles)
    res))

;; oldest server alive determines host then choose random of youngest
;; five servers on that host
;;
(define (server:choose-server areapath)
  ;; 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
  (let* ((serversdat  (server:get-servers-info areapath))
	 (by-time-asc (sort (hash-table-keys serversdat)
			    (lambda (a b)
			      (>= (list-ref (hash-table-ref serversdat a) 2)
				  (list-ref (hash-table-ref serversdat b) 2))))))
    (if (not (null? by-time-asc))
	(let* ((oldest     (last by-time-asc))
	       (oldest-dat (hash-table-ref serversdat oldest))
	       (host       (list-ref oldest-dat 1))
	       (all-valid  (filter (lambda (x)(equal? host (list-ref x 1))) by-time-asc)))
	  (print "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
	  (print "youngest: "(hash-table-ref serversdat (car all-valid)))
	  (car all-valid))
	#f)))
        
;; kind start up of server, wait before allowing another server for a given
;; area to be launched
;;
(define (server:kind-run areapath)
  ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
  ;; and wait for it to be at least <server idletime> seconds old