Megatest

Check-in [4115ca72bc]
Login
Overview
Comment:Improved run away server throttling
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: 4115ca72bca6b4bac72a2add68ad95df1030f29e
User & Date: matt on 2023-04-10 19:36:57
Other Links: branch diff | manifest | tags
Context
2023-04-11
08:21
Fixed overlapping calls to sync to on disk db check-in: 4c15e85b4d user: matt tags: v1.80
2023-04-10
19:36
Improved run away server throttling check-in: 4115ca72bc user: matt tags: v1.80
16:16
Some updates from code review check-in: 448f45b91b user: mrwellan tags: v1.80
Changes

Modified api.scm from [98116370e9] to [b07878d20a].

250
251
252
253
254
255
256
257

258
259
260
261
262
263
264
250
251
252
253
254
255
256

257
258
259
260
261
262
263
264







-
+







			    (else
			     (if (not ok)(debug:print 0 *default-log-port* "ERROR: "cmd", run-id "run-id", not correct for dbfname "(dbr:dbstruct-dbfname dbstruct)))
			     (assert ok "FATAL: database file and run-id not aligned.")))))
		(ttdat   *server-info*)
		(server-state (tt-state ttdat))
		(status  (cond
			  ;; ((> newcount 600) 'busy)
			  ((> newcount 50) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
			  ((> newcount 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
			  (else 'ok)))
		(errmsg  (case status
			   ((busy)   (conc "Server overloaded, "newcount" threads in flight"))
			   ((loaded) (conc "Server loaded, "newcount" threads in flight"))
			   (else     #f)))
		(result  (case status
			   ((busy)  (- newcount 29)) ;; call back in as many seconds

Modified dbmod.scm from [e3fed73fc8] to [2c4a7875e4].

179
180
181
182
183
184
185





186
187


188
189
190
191
192
193
194
179
180
181
182
183
184
185
186
187
188
189
190


191
192
193
194
195
196
197
198
199







+
+
+
+
+
-
-
+
+







					    (if (eq? (dbcache-mode) 'inmem)
						#f
						tmpdb)
					    ))
	 (write-access (file-write-access? dbpath))
	 (db           (dbmod:safely-open-db dbfullname init-proc write-access))
	 (tables       (db:sync-all-tables-list keys)))
    (if (not (and (sqlite3:database? inmem)
		  (sqlite3:database? db)))
	(begin
	  (debug:print 0 *default-log-port* "ERROR: Failed to properly open "dbfname-in", exiting immediately.")
	  (exit)))
    (assert (sqlite3:database? inmem) "FATAL: open-dbmoddb: inmem is not a db")
    (assert (sqlite3:database? db) "FATAL:  open-dbmoddb: db is not a db")
    ;; (assert (sqlite3:database? inmem) "FATAL: open-dbmoddb: inmem is not a db")
    ;; (assert (sqlite3:database? db) "FATAL:  open-dbmoddb: db is not a db")
    (dbr:dbstruct-inmem-set!     dbstruct inmem)
    (dbr:dbstruct-ondiskdb-set!  dbstruct db)
    (dbr:dbstruct-dbfile-set!    dbstruct dbfullname)
    (dbr:dbstruct-dbfname-set!   dbstruct dbfname)
    (dbr:dbstruct-sync-proc-set! dbstruct
				 (lambda (last-update)
				   ;; (if db

Modified tcp-transportmod.scm from [4f582ce483] to [21933d310d].

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







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







;;
;; Server viability is checked in keep-running. Blindly start and run here.
;;
(define (tt:start-server areapath run-id dbfname-in handler keys)
  (assert areapath "FATAL: areapath not provided for tt:start-server")
  ;; is there already a server for this dbfile? Then exit.
  (let* ((ttdat   (make-tt areapath: areapath))
	 (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id))))
    ;; (servers (tt:find-server areapath dbfname))) ;; should use tt:get-current-server-info instead
    ;; (if (null? servers)
    (let* ((dbstruct   (dbmod:open-dbmoddb areapath run-id dbfname (dbfile:db-init-proc) keys)))
      (tt-handler-set! ttdat (handler dbstruct))
      (let* ((tcp-thread (make-thread
			  (lambda ()
			    (tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data
			  "tcp-server-thread"))
	     (run-thread (make-thread
			  (lambda ()
			    (tt:keep-running ttdat dbfname dbstruct)))))
	(thread-start! tcp-thread)
	(thread-start! run-thread)
	(thread-join! run-thread) ;; run thread will exit on timeout or other conditions
	(exit)))
	 (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id)))
	 (servers (tt:find-server areapath dbfname))) ;; should use tt:get-current-server-info instead
    (if (> (length servers) 4)
	(begin
	  (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.")
	  (exit))
	(let* ((dbstruct   (dbmod:open-dbmoddb areapath run-id dbfname (dbfile:db-init-proc) keys)))
	  (tt-handler-set! ttdat (handler dbstruct))
	  (let* ((tcp-thread (make-thread
			      (lambda ()
				(tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data
			      "tcp-server-thread"))
		 (run-thread (make-thread
			      (lambda ()
				(tt:keep-running ttdat dbfname dbstruct)))))
	    (thread-start! tcp-thread)
	    (thread-start! run-thread)
	    (thread-join! run-thread) ;; run thread will exit on timeout or other conditions
	    (exit))))))
    ;;(begin
    ;; (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.")
    ;; (exit)))))
    ))

(define (tt:keep-running ttdat dbfname dbstruct)
  ;; verfiy conn for ready
  ;; listener socket has been started by this stage
  ;; wait for a port before creating the registration file
  ;;
  (let* ((db-locked-in #f)