Megatest

Check-in [dbfd08bd90]
Login
Overview
Comment:Start servers for all dbs on first access of main.db. WARNING: This sometimes runs away!
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-start-all
Files: files | file ages | folders
SHA1: dbfd08bd90ab386617b2e42d8b643184ceb4f32e
User & Date: matt on 2023-10-19 21:02:23
Other Links: branch diff | manifest | tags
Context
2023-10-20
04:57
Merged fork check-in: 53900a0d02 user: mrwellan tags: v1.80-start-all
2023-10-19
21:02
Start servers for all dbs on first access of main.db. WARNING: This sometimes runs away! check-in: dbfd08bd90 user: matt tags: v1.80-start-all
2023-10-14
20:19
removed a bit of not-needed junk from rmt.scm Leaf check-in: ffe3df4e65 user: matt tags: v1.80-matt-fixme
Changes

Modified api.scm from [13a08c65d1] to [47ba07ff8b].

310
311
312
313
314
315
316


317
318
319
320























321
322
323
324
325
326
327
310
311
312
313
314
315
316
317
318
319
320


321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350







+
+


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







	   (set! *api-process-request-count* (- *api-process-request-count* 1))
	   ;; (serialize payload)
	   (api:unregister-thread (current-thread))
	   payload))
	(else
	 (assert #f "FATAL: failed to deserialize indat "indat))))))
       
(define *last-refresh-of-dbs* 0)
(define *db-starts-running* #f)

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

  (thread-start!
   (make-thread
    (lambda ()
      (if (and (not *db-starts-running*)
	       (not run-id) ;; i.e. we are mainl.db
	       (> (- (current-seconds) *last-refresh-of-dbs*) 20))
	  (set! *db-starts-running* #t)
	  (let loop ((dbnum 10))
	    (let* ((dbname     (conc dbnum".db")) ;; Yes, this is correct, use dbnum directly
		   (candidates (dbfile:get-process-options *no-sync-db* "server" dbname)))
	      (if (null? candidates)
		  ;; start a server for this dbfile
		  (tt:server-process-run
		   *toppath*
		   (common:get-testsuite-name)
		   (common:find-local-megatest)
		   dbname)))
	    (thread-sleep! 0.5)
	    (if (> dbnum 0)(loop (- dbnum 1)))
	    (set! *db-starts-running* #f)
	    (set! *last-refresh-of-dbs* (current-seconds)))))))
  (case cmd
    ;;===============================================
    ;; READ/WRITE QUERIES
    ;;===============================================

    ((get-keys-write)                        (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
    

Modified dbfile.scm from [172c69b638] to [e8d739219a].

578
579
580
581
582
583
584

585
586
587
588
589
590
591
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592







+







(define (dbfile:register-process nsdb host port pid starttime endtime status purpose dbname mtversion)
  (sqlite3:execute nsdb "INSERT INTO processes (host,port,pid,starttime,endtime,status,purpose,dbname,mtversion) VALUES (?,?,?,?,?,?,?,?,?);"
		   host port pid starttime endtime status purpose dbname mtversion))

(define (dbfile:set-process-status nsdb host pid newstatus)
  (sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid))

;; get list of process records to examine for suitabliity of connecting to
(define (dbfile:get-process-options nsdb purpose dbname)
  (sqlite3:fold-row
   ;; host port pid starttime status mtversion
   (lambda (res . row)
     (cons row res))
   '()
   nsdb

Modified tcp-transportmod.scm from [a1fcad65c5] to [ec84ec4c9e].

136
137
138
139
140
141
142

143

144
145
146
147
148
149
150
136
137
138
139
140
141
142
143

144
145
146
147
148
149
150
151







+
-
+







  (assert (tt:valid-run-id run-id dbfname) "FATAL: invalid run-id "run-id)
  (let* ((conn (hash-table-ref/default (tt-conns ttdat) dbfname #f))
	 (server-start-proc (lambda ()
			      (tt:server-process-run
			       (tt-areapath ttdat)
			       testsuite ;; (dbfile:testsuite-name)
			       (common:find-local-megatest)
			       dbfname ;; run-id
			       run-id))))
			       ))))
    (if conn
	(begin 
          ; (debug:print-info 0 *default-log-port* "already connected to the server")
           conn) ;; we are already connected to the server
	(let* ((sdat (tt:get-current-server-info ttdat dbfname)))
	  (match sdat
	    ((host port start-time server-id pid dbfname2 servinffile)
753
754
755
756
757
758
759
760



761
762
763
764
765

766
767
768
769
770
771
772
754
755
756
757
758
759
760

761
762
763
764
765
766
767

768
769
770
771
772
773
774
775







-
+
+
+




-
+







		      bad-dat)))))))))

;; 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
(define  (tt:server-process-run areapath testsuite mtexe
				dbfname ;; 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))
  (let* (;; (dbfname  (dbmod:run-id->dbfname run-id))
	 (load     (get-normalized-cpu-load))
	 (trying   (length (tt:find-server areapath dbfname)))
	 (nrun     (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
    (cond
     ((> load 2.0)
      (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server.")
      (thread-sleep! 1))