Megatest

Diff
Login

Differences From Artifact [fec0aec4d3]:

To Artifact [f26359a83a]:


237
238
239
240
241
242
243







244

245
246
247
248

249
250
251
252
253
254
255
256


257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

272
273
274
275
276
277
278
279
237
238
239
240
241
242
243
244
245
246
247
248
249
250

251
252
253
254

255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279

280

281
282
283
284
285
286
287







+
+
+
+
+
+
+
-
+



-
+








+
+














-
+
-







			    ((ping) *server-signature*)
			    (else
			     (api:dispatch-request dbstruct cmd run-id params))))))
      (set! *api-process-request-count* newcount)
      (set! *db-last-access* (current-seconds))
      (match indat
	((cmd run-id params meta)
	 (let* ((db-ok  (let* ((dbfname (dbmod:run-id->dbfname run-id))
			       (ok      (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
			  (case cmd
			    ((ping) #t) ;; we are fine
			    (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.")))))
	 (let* ((ttdat   *server-info*)
		(ttdat   *server-info*)
		(server-state (tt-state ttdat))
		(status  (cond
			  ;; ((> newcount 600) 'busy)
			  ;; ((> newcount 300) 'loaded)
			  ((> newcount 300) 'loaded)
			  (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
			   ((loaded)
			    (if (eq? (rmt:transport-mode) 'tcp)
				(thread-sleep! 0.5))
			    (normal-proc cmd run-id params))
			   (else
			    (normal-proc cmd run-id params))))
		(meta   (case cmd
			  ((ping) `((sstate . ,server-state)))
			  (else   `((wait . ,delay-wait)))))
		(payload (list status errmsg result meta)))
	   (set! *api-process-request-count* (- *api-process-request-count* 1))
	   (serialize payload)))
	(else
	 (assert #f "FATAL: failed to deserialize indat "indat))))))
       

(define (api:dispatch-request dbstruct cmd run-id params)
  (if (and (not *no-sync-db*)
  (if (not *no-sync-db*)
	   (member cmd '(db:no-sync-set db:no-sync-get/default db:no-sync-del! db:no-sync-get-lock )))
      (db:open-no-sync-db))
  (case cmd
    ;;===============================================
    ;; READ/WRITE QUERIES
    ;;===============================================

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