Changes In Branch v1.81-multi-server Through [af60709165] Excluding Merge-Ins
This is equivalent to a diff from 6b8bacba76 to af60709165
2024-07-08
| ||
12:55 | CI/CD: Automated commit after successful test, build, and deploy for v1.81-fix-api-changed check-in: 0249193b68 user: ramartin tags: v1.81 | |
03:00 | Getting close on gating runs from starting new tests on server load high. check-in: 6a90d15b55 user: matt tags: v1.81-multi-server | |
2024-07-07
| ||
20:09 | Sort servers based on number of threads running to estimate load check-in: af60709165 user: matt tags: v1.81-multi-server | |
2024-07-03
| ||
19:08 | Missing change check-in: 25cae1c008 user: mrwellan tags: v1.81-multi-server | |
12:50 | Fixed an unbound variable and made it handle 1.81. Leaf check-in: dc561cf357 user: mmgraham tags: v1.81-fix-api-changed | |
2024-07-02
| ||
13:55 | Start on increasing allowed number of servers for a db file check-in: 66e4d2383a user: mrwellan tags: v1.81-multi-server | |
2024-07-01
| ||
17:27 | Changed version to v1.8101 check-in: 6b8bacba76 user: mmgraham tags: v1.81, v1.8101 | |
16:57 | v1.81-test-control-panel branch into 1.81 check-in: a6b2094831 user: ramartin tags: v1.81 | |
Modified api.scm from [bf55d9f0a8] to [0ec121fad4].
︙ | ︙ | |||
242 243 244 245 246 247 248 | (else (assert ok "FATAL: database file and run-id not aligned."))))) (ttdat *server-info*) (server-state (tt-state ttdat)) (maxthreads 20) ;; make this a parameter? (status (cond ((> numthreads maxthreads) | > > > > > > > | > > | < < | 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 288 289 290 291 292 293 294 295 296 297 | (else (assert ok "FATAL: database file and run-id not aligned."))))) (ttdat *server-info*) (server-state (tt-state ttdat)) (maxthreads 20) ;; make this a parameter? (status (cond ((> numthreads maxthreads) (let* ((testsuite (common:get-testsuite-name)) (mtexe (common:find-local-megatest)) (proc (lambda () ;; we are overloaded, try to start another server (debug:print 0 *default-log-port* "Too many threads running, starting another server") (tt:server-process-run *toppath* testsuite mtexe run-id)))) (set! *server-start-requests* (cons proc *server-start-requests*))) ;; 'busy 'loaded ;; not ideal since the client will not backoff ) (else 'ok))) (errmsg (case status ((busy) (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads))) ((loaded) (conc "Server loaded, "numthreads" threads in flight")) (else #f))) (result (case status ((busy) (if (eq? cmd 'ping) (normal-proc cmd run-id params) ;; numthreads must be greater than 5 for busy (* 0.1 (- numthreads maxthreads)) ;; was 15 )) ;; (- numthreads 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)(sload . ,numthreads))) (else `((wait . ,delay-wait))))) (payload (list status errmsg result meta))) ;; (cmd run-id params meta) (db:add-stats cmd run-id params (- (current-milliseconds) start-t)) payload)) (else (assert #f "FATAL: failed to deserialize indat "indat)))))) ;; (set! *api-process-request-count* (- *api-process-request-count* 1)) ;; (serialize payload) (api:unregister-thread (current-thread)) result))) (define *api-halt-writes* #f) (define (api:dispatch-request dbstruct cmd run-id params) (if (not *no-sync-db*) (db:open-no-sync-db)) (let* ((start-time (current-milliseconds))) |
︙ | ︙ |
Modified common.scm from [1039cd02f7] to [098f0c5374].
︙ | ︙ | |||
399 400 401 402 403 404 405 | (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) ;; From 1.70 to 1.80, db's are compatible. | | > > < | | < | | < < | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 | (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) ;; From 1.70 to 1.80, db's are compatible. ;; ;; BUG: This logic is almost certainly not quite correct. ;; (define (common:api-changed?) (let* ((megatest-major-version (substring (->string megatest-version) 0 4)) (run-major-version (substring (conc (common:get-last-run-version)) 0 4))) (and (not (member megatest-major-version '("1.81" "1.80"))) (not (equal? megatest-major-version run-major-version))))) ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct #!key (full #f)) (case (rmt:transport-mode) |
︙ | ︙ |
Modified tcp-transportmod.scm from [2d80f8e52f] to [a6f9fa170f].
︙ | ︙ | |||
203 204 205 206 207 208 209 210 211 212 | run-id))))) (if conn (begin (debug:print-info 2 *default-log-port* "already connected to a server for " dbfname) conn) ;; we are already connected to the server ;; no conn (let* ((sdats (tt:get-server-info-sorted ttdat dbfname)) (sdat (if (null? sdats) #f | > > > > | > > > > > > > | | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | run-id))))) (if conn (begin (debug:print-info 2 *default-log-port* "already connected to a server for " dbfname) conn) ;; we are already connected to the server ;; no conn ;; find server with lowest number of threads running (i.e. lowest load) ;; (let* ((sdats (tt:get-server-info-sorted ttdat dbfname)) (sdat (if (null? sdats) #f ;; choose server with lowest threads count (car (sort sdats (lambda (a b) (let* ((load-a (tt:get-server-threads a)) (load-b (tt:get-server-threads b))) (< load-a load-b)))))))) ;; (let ((indx (max (random (- (length sdats) 1)) 0))) ;; (list-ref sdats indx))))) (debug:print-info 1 *default-log-port* "found sdat " sdat" from sdats: "sdats) (match sdat ((host port start-time server-id pid dbfname2 servinffile) (assert (equal? dbfname dbfname2) "FATAL: read server info from wrong file.") (debug:print-info 2 *default-log-port* "no conn - in match servinffile:" servinffile) (let* ((host-port (conc host":"port)) (conn (make-tt-conn host: host port: port |
︙ | ︙ | |||
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | ;; returns ( result . ping_time ) (define (tt:timed-ping host port server-id) (let* ((start-time (current-milliseconds)) (result (tt:ping host port server-id))) (cons result (- (current-milliseconds) start-time)))) (define (tt:ping host port server-id #!optional (tries-left 5)) (let* ((res (tt:send-receive-direct host port `(ping #f #f #f) ping-mode: #t)) ;; please send me your server-id (try-again (lambda () (if (> tries-left 0) (begin (thread-sleep! 1) (tt:ping host port server-id (- tries-left 1))) #f)))) ;; ;; need two threads, one a 5 second timer ;; (match res ((status errmsg result meta) (if (equal? result server-id) (let* ((server-state (alist-ref 'sstate meta))) ;; (debug:print 0 *default-log-port* "Ping to "host":"port" successful.") (or server-state 'unk)) ;; then we are good (begin | > > > > > > > > > > > > > > > > > > > > > > > > > | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 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 351 | ;; returns ( result . ping_time ) (define (tt:timed-ping host port server-id) (let* ((start-time (current-milliseconds)) (result (tt:ping host port server-id))) (cons result (- (current-milliseconds) start-time)))) (define *server-load* (make-hash-table)) (define (tt:save-server-meta host port meta) (hash-table-set! *server-load* (conc host":"port) meta)) (define (tt:get-server-threads dat) (let* ((host (car dat)) (port (cadr dat)) (meta (tt:get-server-meta host port #t))) (if (list? meta) (alist-ref 'sload meta) #f))) ;; lazy get, does not auto-refresh meta, this might be a problem ;; (define (tt:get-server-meta host port #!optional (do-ping #f)) (let* ((meta (hash-table-ref/default *server-load* (conc host":"port) #f))) (if (and (not meta) do-ping) (begin (tt:timed-ping host port #f) (hash-table-ref/default *server-load* (conc host":"port) #f)) meta))) (define (tt:ping host port server-id #!optional (tries-left 5)) (let* ((res (tt:send-receive-direct host port `(ping #f #f #f) ping-mode: #t)) ;; please send me your server-id (try-again (lambda () (if (> tries-left 0) (begin (thread-sleep! 1) (tt:ping host port server-id (- tries-left 1))) #f)))) ;; ;; need two threads, one a 5 second timer ;; (match res ((status errmsg result meta) (tt:save-server-meta host port meta) (if (equal? result server-id) (let* ((server-state (alist-ref 'sstate meta))) ;; (debug:print 0 *default-log-port* "Ping to "host":"port" successful.") (or server-state 'unk)) ;; then we are good (begin (if server-id (debug:print 0 *default-log-port* "WARNING: server-id does not match, expected: "server-id", got: "result)) #f))) (else ;; (debug:print 0 *default-log-port* "res not in form (status errmsg result meta), got: "res) (try-again))))) ;; client side handler ;; ;;(tt:handler #<tt> get-keys #f () 2 #f "/home/matt/data/megatest/ext-tests" #f "main.db" "ext-tests" "/home/matt/data/megatest/bin/.22.04/../megatest") ;;g (define (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc) ;; connect-to-server will start a server if needed. (let* ((areapath (tt-areapath ttdat)) (conn (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))) ;; looks up conn keyed by dbfname (if conn ;; have connection, call the server (let* ((res (tt:send-receive ttdat conn cmd run-id params))) |
︙ | ︙ | |||
330 331 332 333 334 335 336 337 338 339 340 341 342 343 | (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1)) (debug:print 0 *default-log-port* errmsg) (thread-sleep! dly) (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc))) ((loaded) (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.") (tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn)) result) ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe)) (else result))) (else ;; did not receive properly formated result (if (not res) ;; tt:send-receive telling us that communication failed (let* ((host (tt-conn-host conn)) (port (tt-conn-port conn)) | > > > | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 | (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1)) (debug:print 0 *default-log-port* errmsg) (thread-sleep! dly) (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc))) ((loaded) (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.") (tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn)) ;; this would be a good place to force reconnection and connect to a different server result) ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe)) (else result))) (else ;; did not receive properly formated result (if (not res) ;; tt:send-receive telling us that communication failed (let* ((host (tt-conn-host conn)) (port (tt-conn-port conn)) |
︙ | ︙ | |||
380 381 382 383 384 385 386 | ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe) ))))) (begin (thread-sleep! 1) ;; no conn yet set up, give it a rest and try again (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc))))) ;; gets server info and appends path to server file | | > > | | 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 | ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe) ))))) (begin (thread-sleep! 1) ;; no conn yet set up, give it a rest and try again (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc))))) ;; gets server info and appends path to server file ;; sorts by age, --oldest-- now newest first ;; ;; move the ping here? ;; ;; returns list of (host port startseconds server-id servinfofile) ;; (define (tt:get-server-info-sorted ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (sfiles (tt:find-server areapath dbfname)) (sdats (filter car (map tt:server-get-info sfiles))) ;; first element is #f if the file disappeared while being read (sorted (sort sdats (lambda (a b) (let* ((starta (list-ref a 2)) (startb (list-ref b 2))) (if (eq? starta startb) (string>? (list-ref a 3)(list-ref b 3)) ;; if servers started at same time look at server-id (> starta startb)))))) (count 0)) (for-each (lambda (rec) (if (or (> (length sorted) 1) (common:low-noise-print 120 "server info sorted")) (debug:print 2 *default-log-port* "SERVER #"count": "(string-intersperse (map conc sorted) ", "))) (set! count (+ count 1))) |
︙ | ︙ | |||
516 517 518 519 520 521 522 523 524 525 526 527 528 529 | ;;====================================================================== ;; server ;;====================================================================== (define (tt:sync-dbs ttdat) #f) ;; start the listener and start responding to requests ;; ;; NOTE: organise by dbfname, not run-id so we don't need ;; to pull in more modules ;; ;; This is the routine called in megatest.scm to start a server. NOTE: sequence is different for main.db vs. X.db | > > | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | ;;====================================================================== ;; server ;;====================================================================== (define (tt:sync-dbs ttdat) #f) (define *server-start-requests* '()) ;; start the listener and start responding to requests ;; ;; NOTE: organise by dbfname, not run-id so we don't need ;; to pull in more modules ;; ;; This is the routine called in megatest.scm to start a server. NOTE: sequence is different for main.db vs. X.db |
︙ | ︙ | |||
571 572 573 574 575 576 577 | (same-host (or (not prime-host) ;; i.e. this is the first host (equal? prime-host host))) (keep-srv (and good-ping same-host))) (if keep-srv (loop (cdr servrs) host (cons servdat result)) | | | > > | | | > | | | | > | | 614 615 616 617 618 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 | (same-host (or (not prime-host) ;; i.e. this is the first host (equal? prime-host host))) (keep-srv (and good-ping same-host))) (if keep-srv (loop (cdr servrs) host (cons servdat result)) (let* ((modtime (file-modification-time servinfofile))) ;; if the .servinfo hasn't been touched in five min ;; we can be pretty sure the server is truly dead (if (> (- (current-seconds) modtime) 360) (handle-exceptions exn (debug:print-info 0 *default-log-port* "Error removing server info file: "servinfofile", " (condition->list exn)) (delete-file* servinfofile)) (loop (cdr servrs) prime-host result)))))) (else ;; can't delete it as we don't have a filename. NOTE: Should never get here. (debug:print-info 0 *default-log-port* "ERROR: bad servinfo record \""servdat"\"") (loop (cdr servrs) prime-host result)) ;; drop ))))) (home-host (if (null? good-srvrs) #f (caar good-srvrs)))) ;; by here we have a trustworthy list of servers and we have removed the .servinfo file for any unresponsive servers ;; and the list is in good-srvrs ;; (cond ((not home-host) ;; no servers yet, go ahead and start (debug:print-info 0 *default-log-port* "No servers yet, starting on "(get-host-name))) ((> (length good-srvrs) 3) ;; don't need more, just exit (debug:print-info 0 *default-log-port* "Have "(length good-srvrs)", no need for more, exiting.") (exit)) ((not (equal? home-host (get-host-name))) ;; there is a home-host and we are not on it (debug:print-info 0 *default-log-port* "Prime main server is on host "home-host", but we are on host "(get-host-name)", exiting.") (exit)) (else (debug:print-info 0 *default-log-port* "Starting on host "(get-host-name)", along with "(length good-srvrs)" other servers."))) |
︙ | ︙ | |||
620 621 622 623 624 625 626 627 628 629 630 631 632 633 | (thread-sleep! 0.25) (loop (+ count 1))) (begin (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set! Exiting.") (exit))))) ;; create a servinfo file start keep-running (debug:print 0 *default-log-port* "Creating servinfo file for " dbfname) (tt:create-server-registration-file ttdat dbfname) (procinf-status-set! *procinf* "running") (tt-state-set! ttdat 'running) (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) | > > | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 | (thread-sleep! 0.25) (loop (+ count 1))) (begin (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set! Exiting.") (exit))))) ;; create a servinfo file start keep-running ;; On WSL there seems to be a race condition where the .servinfo file ;; is not created fast enough (debug:print 0 *default-log-port* "Creating servinfo file for " dbfname) (tt:create-server-registration-file ttdat dbfname) (procinf-status-set! *procinf* "running") (tt-state-set! ttdat 'running) (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) |
︙ | ︙ | |||
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 | nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*))) (debug:print 0 *default-log-port* "Exiting now.") (exit)))))) (define (tt:keep-running ttdat dbfname dbstruct) ;; at this point the server is running and responding to calls, we just monitor ;; for db calls and exit if there are none. ;; if I am not in the first 3 servers, exit (let* ((start-time (current-seconds))) (let loop () (let* ((servers (tt:get-server-info-sorted ttdat dbfname)) (home-host (if (null? servers) #f (caar servers))) (my-index (list-index (lambda (x) (equal? (list-ref x 6) (tt-servinf-file ttdat))) servers)) (ok (cond ((not *server-run*) (debug:print 0 *default-log-port* "WARNING: received a stop server from client by remote request.") #f) ((null? servers) (debug:print 0 *default-log-port* "WARNING: no servinfo files found, this cannot be.") #f) ;; not ok | > > > > > | | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 | nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*))) (debug:print 0 *default-log-port* "Exiting now.") (exit)))))) (define (tt:keep-running ttdat dbfname dbstruct) (thread-sleep! 1) ;; at this point the server is running and responding to calls, we just monitor ;; for db calls and exit if there are none. ;; if I am not in the first 3 servers, exit (let* ((start-time (current-seconds))) (let loop () (let* ((servers (tt:get-server-info-sorted ttdat dbfname)) (home-host (if (null? servers) #f (caar servers))) (my-index (list-index (lambda (x) (equal? (list-ref x 6) (tt-servinf-file ttdat))) servers)) (ok (cond ((not my-index) (debug:print 0 *default-log-port* "WARNING: Apparently I don't exist.") #f) ;; keep trying or give up? ((not *server-run*) (debug:print 0 *default-log-port* "WARNING: received a stop server from client by remote request.") #f) ((null? servers) (debug:print 0 *default-log-port* "WARNING: no servinfo files found, this cannot be.") #f) ;; not ok ((> my-index 3) (debug:print 0 *default-log-port* "WARNING: there are more than three servers ahead of me, I'm not needed, exiting.") #f) ;; not ok to not be in first three ((eq? (tt-state ttdat) 'running) #t) ;; we are good to keep going ((> (- (current-seconds) start-time) 30) (debug:print 0 *default-log-port* "WARNING: over 30 seconds and not yet in runnning mode. Exiting.") #f) (else #t)))) (if ok |
︙ | ︙ | |||
694 695 696 697 698 699 700 | (let* ((sinfo-file (tt-servinf-file ttdat))) ;; (debug:print 0 *default-log-port* "INFO: touching "sinfo-file) (set! (file-modification-time sinfo-file) (current-seconds)) ((dbr:dbstruct-sync-proc dbstruct) last-update) (dbr:dbstruct-last-update-set! dbstruct curr-secs)))) (if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param)) | > > > > > > | > > | 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 | (let* ((sinfo-file (tt-servinf-file ttdat))) ;; (debug:print 0 *default-log-port* "INFO: touching "sinfo-file) (set! (file-modification-time sinfo-file) (current-seconds)) ((dbr:dbstruct-sync-proc dbstruct) last-update) (dbr:dbstruct-last-update-set! dbstruct curr-secs)))) (if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param)) ;; process any requests to start a new server due to load on this one (let* ((requests *server-start-requests*)) (set! *server-start-requests* '()) (if (> (length requests) 0) (debug:print-info 0 *default-log-port* "Processing "(length requests)" server start requests")) (for-each (lambda (proc) (proc) (thread-sleep! 1)) requests) (thread-sleep! 5) (loop))))) (tt:shutdown-server ttdat) (debug:print 0 *default-log-port* "INFO: Server timed out, exiting from tt:keep-running."))) (define (tt:shutdown-server ttdat) |
︙ | ︙ | |||
726 727 728 729 730 731 732 | (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname)) (serv-id (tt:mk-signature areapath))) (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname) (tt-servinf-file-set! ttdat servinf) (with-output-to-file servinf (lambda () (print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname))) | > > > > > > > > | > > | | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 | (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname)) (serv-id (tt:mk-signature areapath))) (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname) (tt-servinf-file-set! ttdat servinf) (with-output-to-file servinf (lambda () (print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname))) (let loop ((count 0)) (if (not (file-exists? servinf)) (begin (debug:print 0 *default-log-port* "WARNING: file "servinf" was created but it doesn't show up on disk! We'll try again.") (thread-sleep! 1) (if (> count 10) (debug:print 0 *default-log-port* "WARNING: file "servinf" was not created.") (loop (+ count 1)))))) serv-id)) ;; find valid server ;; get servers listed, last part of name must match :<dbfname> ;; if more than one, wait one second and look again ;; ;; NOTE: this only gets the servinfo data, no network activity here ;; i.e. no ping etc. ;; (define (tt:find-server areapath dbfname) (let* ((servdir (tt:get-servinfo-dir areapath)) (sfiles (glob (conc servdir"/*:"dbfname))) (goodfiles '())) ;; filter the files here by looking in processes table (if we are not main.db) |
︙ | ︙ | |||
800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 | (define *last-server-start* (make-hash-table)) (define (tt:too-recent-server-start dbfname) (let* ((last-run-time (hash-table-ref/default *last-server-start* dbfname #f))) (and last-run-time (< (- (current-seconds) last-run-time) 5)))) ;; 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 (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))) | > > > | > | | | | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 | (define *last-server-start* (make-hash-table)) (define (tt:too-recent-server-start dbfname) (let* ((last-run-time (hash-table-ref/default *last-server-start* dbfname #f))) (and last-run-time (< (- (current-seconds) last-run-time) 5)))) (define *last-server-start-request-time* 0) ;; 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 (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))) (if (or (< (- (current-seconds) *last-server-start-request-time*) 5) ;; attempted start less than 5 sec ago (tt:too-recent-server-start dbfname)) #f (let* ((load (get-normalized-cpu-load)) (srvrs (tt:find-server areapath dbfname)) (trying (length srvrs)) (nrun (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname)))) (set! *last-server-start-request-time* (current-seconds)) (cond ((> load 4.0) (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 4.0. Not starting a server. Please reduce the load on "(get-host-name)" by killing some processes") (thread-sleep! 1) ;; I'm not convinced that a delay here is helpful. -mrw- #f) ((> nrun 100) (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.") (thread-sleep! 1) #f) ((> trying 3) (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.") (thread-sleep! 1) #f) (else (if (not (file-exists? (conc areapath"/logs"))) (create-directory (conc areapath"/logs") #t)) (let* ((logfile (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log")) |
︙ | ︙ |