Comment: | updated to latest v1.63, WIP |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.63-configdbsync |
Files: | files | file ages | folders |
SHA1: |
8e63364af0f21d21b388bcefadbc3184 |
User & Date: | srehman on 2017-01-09 12:04:45 |
Other Links: | branch diff | manifest | tags |
2017-01-09
| ||
17:17 | added sqlite3 switch back check-in: 4b9956034c user: srehman tags: v1.63-configdbsync | |
12:04 | updated to latest v1.63, WIP check-in: 8e63364af0 user: srehman tags: v1.63-configdbsync | |
2017-01-05
| ||
11:03 | added .server verification against running server ; also touching .server periodically and checking its age to detect and recover from potential server crashes check-in: 65358a4d53 user: bjbarcla tags: v1.63 | |
2017-01-03
| ||
14:03 | merged with latest v1.63 check-in: 7e69485459 user: srehman tags: v1.63-configdbsync | |
Modified client.scm from [50265f350f] to [cbdbeb9ff4].
︙ | ︙ | |||
195 196 197 198 199 200 201 | run-id (tasks:hostinfo-get-interface server-dat) (tasks:hostinfo-get-port server-dat) " client:setup (server-dat = #t)") (if (> remaining-tries 8) (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time | | | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | run-id (tasks:hostinfo-get-interface server-dat) (tasks:hostinfo-get-port server-dat) " client:setup (server-dat = #t)") (if (> remaining-tries 8) (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time (server:try-running *toppath*) (thread-sleep! 5) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) (if (< num-available 2) (server:try-running *toppath*)) (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) ;; keep this as a function to ease future (define (client:start run-id server-info) (http-transport:client-connect (tasks:hostinfo-get-interface server-info) (tasks:hostinfo-get-port server-info))) |
︙ | ︙ |
Modified common.scm from [d2df0eaa3f] to [6953f07d9c].
︙ | ︙ | |||
134 135 136 137 138 139 140 | (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) (defstruct remote (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) (defstruct remote (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) (server-url (if *toppath* (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive (conndat #f) (transport *transport-type*) (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds ;; launching and hosts (defstruct host |
︙ | ︙ | |||
577 578 579 580 581 582 583 | (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) ) (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (let ((dbstruct (db:setup))) (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") (let loop () | | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 | (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) ) (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (let ((dbstruct (db:setup))) (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") (let loop () ;;(BB> "watchdog loop. pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) ;; sync for filesystem local db writes ;; (mutex-lock! *db-multi-sync-mutex*) (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write (sync-in-progress *db-sync-in-progress*) (should-sync (and (not *time-to-exit*) (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum |
︙ | ︙ | |||
616 617 618 619 620 621 622 | (set! last-time start-time) (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) | | > | 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 | (set! last-time start-time) (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) (if (and (not *time-to-exit*) (< count 4)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (if (not *time-to-exit*) (loop)))) (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)" this-wd-num="this-wd-num))))))) (define (std-exit-procedure) (on-exit (lambda () 0)) ;;(BB> "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)) |
︙ | ︙ | |||
675 676 677 678 679 680 681 682 683 684 685 686 687 688 | ) 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! | > | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 | ) 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) ;;(BB> "got signal "signum) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! |
︙ | ︙ |
Modified common_records.scm from [4d93fb5556] to [e3400966c5].
︙ | ︙ | |||
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | (lambda () (if *logging* (db:log-event (apply conc params)) (apply print params) ))))) ;; Brandon's debug printer shortcut (indulge me :) (define (BB> . in-args) (let* ((stack (get-call-chain)) (location #f)) (for-each (lambda (frame) (let* ((this-loc (vector-ref frame 0)) (this-func (cadr (string-split this-loc " ")))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) | > | | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | (lambda () (if *logging* (db:log-event (apply conc params)) (apply print params) ))))) ;; Brandon's debug printer shortcut (indulge me :) (define *BB-process-starttime* (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) (location #f)) (for-each (lambda (frame) (let* ((this-loc (vector-ref frame 0)) (this-func (cadr (string-split this-loc " ")))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) (let ((dp-args (append (list 0 *default-log-port* (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) in-args))) (apply debug:print dp-args)))) (define *BBpp_custom_expanders_list* (make-hash-table)) ;; register hash tables with BBpp. |
︙ | ︙ |
Modified dashboard-tests.scm from [cd363a9628] to [4046dd1f97].
︙ | ︙ | |||
471 472 473 474 475 476 477 | (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn | | | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 | (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dashboard-tests:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) |
︙ | ︙ |
Modified db.scm from [ef59b3d683] to [33d7fe0a70].
︙ | ︙ | |||
289 290 291 292 293 294 295 | (if (args:get-arg "-server") (if (configf:get-section *configdat* "ext-sync") (let* ((dblist (configf:get-section *configdat* "ext-sync")) (res '()) (cfgdb #f)) (for-each (lambda (dbitem) (let* ((stringsplit (string-split (cadr dbitem))) | | > > > > > > > > | | < < | > > | > | 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 | (if (args:get-arg "-server") (if (configf:get-section *configdat* "ext-sync") (let* ((dblist (configf:get-section *configdat* "ext-sync")) (res '()) (cfgdb #f)) (for-each (lambda (dbitem) (let* ((stringsplit (string-split (cadr dbitem))) (dbtype (string->symbol (car stringsplit))) (dbinfo '()) (cred '())) (for-each (lambda (x) (if (not (eqv? (string->symbol x) dbtype)) (let* ((pair (string-split x ":"))) (if (not (eqv? pair '())) (set! dbinfo (cons (cons (string->symbol (car pair)) (cadr pair)) dbinfo)))))) stringsplit) (set! cfgdb (dbi:open dbtype dbinfo)) (set! res (cons (cons cfgdb (alist-ref 'host dbinfo)) res)) )) dblist) (print res) (dbr:dbstruct-slave-dbs-set! dbstruct res) ))) ;; (mutex-unlock! *rundb-mutex*) (if (and (not dbfexists) write-access) ;; *db-write-access*) ;; did not have a prior db and do have write access (begin (debug:print 0 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data from " (db:dbdat-get-path mtdb)) (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)) |
︙ | ︙ | |||
544 545 546 547 548 549 550 551 552 553 554 555 556 557 | ;; db's are dbdat's ;; ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; (define (db:sync-tables tbls last-update fromdb todb . slave-dbs) (set! todb (cons (dbi:convert (db:dbdat-get-db todb)) (db:dbdat-get-path todb))) (set! fromdb (cons (dbi:convert (db:dbdat-get-db fromdb)) (db:dbdat-get-path fromdb))) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") | > | 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | ;; db's are dbdat's ;; ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; (define (db:sync-tables tbls last-update fromdb todb . slave-dbs) (print "Slave-dbs: " slave-dbs) (set! todb (cons (dbi:convert (db:dbdat-get-db todb)) (db:dbdat-get-path todb))) (set! fromdb (cons (dbi:convert (db:dbdat-get-db fromdb)) (db:dbdat-get-path fromdb))) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") |
︙ | ︙ | |||
601 602 603 604 605 606 607 | (num->field (apply vector (map car fields))) (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria (conc " " (car last-update) ">=" (cdr last-update)) "") ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " | | > | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | (num->field (apply vector (map car fields))) (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria (conc " " (car last-update) ">=" (cdr last-update)) "") ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (tabletypes '()) (totrecords 0) (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) (todat (make-hash-table)) (count 0)) ;; set up the field->num table (for-each |
︙ | ︙ | |||
646 647 648 649 650 651 652 653 654 655 656 657 658 659 | (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (dbi:convert (db:dbdat-get-db targdb))) (stmth (dbi:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) (dbi:with-transaction db | > > > > > > > > > > > > > > > | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 | (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (if (eqv? (dbi:db-dbtype (db:dbdat-get-db targdb)) 'pgd) (let* ((prep "")) (for-each (lambda (row) (set! tabletypes (cons (cons (string->symbol (vector-ref row 1)) (vector-ref row 2)) tabletypes))) (dbi:pull-metadata (db:dbdat-get-db fromdb) tablename)) (set! prep (string-intersperse (map (lambda (x) (alist-ref (string->symbol (car x)) tabletypes)) fields) ",")) (set! prep (conc "PREPARE full-ins (" prep ") AS INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) VALUES ( ")) (let loop ((i 1)) (set! prep (conc prep "$" i ",")) (if (< i (- num-fields 1)) (loop (+ i 1)) (set! prep (conc prep "$" (+ i 1) ")")))) (set! full-ins prep))) (let* ((db (dbi:convert (db:dbdat-get-db targdb))) (stmth (dbi:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) (dbi:with-transaction db |
︙ | ︙ |
Modified http-transport.scm from [285317a3d3] to [880b0371c4].
︙ | ︙ | |||
381 382 383 384 385 386 387 | (last-access 0) (server-timeout (server:get-timeout)) (server-going #f)) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) | | > > | > | > | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 | (last-access 0) (server-timeout (server:get-timeout)) (server-going #f)) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) ;;(BB> "http-transport: top of loop; count="count" server-state="server-state" bad-sync-count="bad-sync-count" server-going="server-going) ;; Use this opportunity to sync the tmp db to megatest.db (if (not server-going) ;; *dbstruct-db* ;; Removed code is pasted below (keeping it around until we are clear it is not needed). ;; no *dbstruct-db* yet, set running after our first pass through and start the db (if (eq? server-state 'available) (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers (if (equal? new-server-id server-id) (begin (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") ;;(BB> "http-transport: ->dbprep") (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access (set! *dbstruct-db* (db:setup)) ;; run-id)) (set! server-going #t) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running") ;;(BB> "http-transport: ->running") (server:write-dotserver *toppath* iface port (current-process-id) 'http) (thread-start! *watchdog*) (server:complete-attempt *toppath*)) (begin ;; gotta exit nicely ;;(BB> "http-transport: ->collision") (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision") (http-transport:server-shutdown server-id port)))))) ;; when things go wrong we don't want to be doing the various queries too often ;; so we strive to run this stuff only every four seconds or so. (let* ((sync-time (- (current-milliseconds) start-time)) (rem-time (quotient (- 4000 sync-time) 1000))) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time))) |
︙ | ︙ | |||
422 423 424 425 426 427 428 | (mutex-unlock! *heartbeat-mutex*) (if (or (not (equal? sdat (list iface port))) (not server-id)) (begin (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info") (set! iface (car sdat)) | | > > > > > | < | | | | | | | | | | > > | | 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 471 472 473 474 475 476 477 478 479 | (mutex-unlock! *heartbeat-mutex*) (if (or (not (equal? sdat (list iface port))) (not server-id)) (begin (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info") (set! iface (car sdat)) (set! port (cadr sdat)) (server:write-dotserver *toppath* iface port (current-process-id) 'http))) ;; Transfer *db-last-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *db-last-access*) (mutex-unlock! *heartbeat-mutex*) ;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout) ;; ;; no_traffic, no running tests, if server 0, no running servers ;; ;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) ;; (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)) (adjusted-timeout (if (> hrs-since-start 1) (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour server-timeout))) (if (common:low-noise-print 120 "server timeout") (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout)) (cond ((not (server:confirm-dotserver *toppath* iface port (current-process-id) 'http)) (debug:print-info 0 *default-log-port* "Server .server file does not exist or contents do not match. Initiate server shutdown.") (http-transport:server-shutdown server-id port)) ((and *server-run* (> (+ last-access server-timeout) (current-seconds))) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) ;; ;; Consider implementing some smarts here to re-insert the record or kill self is ;; the db indicates so ;; ;; (if (tasks:server-am-i-the-server? tdb run-id) ;; (tasks:server-set-state! tdb server-id "running")) ;; (loop 0 server-state bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timeed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown server-id port))))))) ;; code cut out from above ;; ;; (condition-case ;; ;; (if (and (member (mutex-state *db-sync-mutex*) '(abandoned not-abandoned)) ;; ;; (> (- (current-seconds) *db-last-sync*) 5)) ;; if not currently being synced nor recently synced ;; (db:sync-touched *dbstruct-db* *run-id* force-sync: #t) ;; usually done in the watchdog, not here. |
︙ | ︙ | |||
484 485 486 487 488 489 490 491 492 493 494 495 496 497 | ;; (if (and (<= rem-time 4) ;; (> rem-time 0)) ;; (thread-sleep! rem-time) ;; (thread-sleep! 4))) ;; fallback for if the math is changed ... (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; ;; start_shutdown ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up (portlogger:open-run-close portlogger:set-port port "released") | > | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 | ;; (if (and (<= rem-time 4) ;; (> rem-time 0)) ;; (thread-sleep! rem-time) ;; (thread-sleep! 4))) ;; fallback for if the math is changed ... (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) ;;(BB> "http-transport:server-shutdown called") (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; ;; start_shutdown ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up (portlogger:open-run-close portlogger:set-port port "released") |
︙ | ︙ | |||
511 512 513 514 515 516 517 518 519 520 521 522 523 524 | (/ *total-non-write-delay* *number-non-write-queries*)) " ms") (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") ;; if the .server file contained :myport then we can remove it (server:remove-dotserver-file *toppath* port) (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) | > < | < < | | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 | (/ *total-non-write-delay* *number-non-write-queries*)) " ms") (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") ;; if the .server file contained :myport then we can remove it (server:remove-dotserver-file *toppath* port) ;;(BB> "http-transport:server-shutdown -> exit") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) (server:attempting-start *toppath*) (let* ((tdbdat (tasks:open-db))) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (begin (daemon:ize) (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it (begin (current-error-port *alt-log-file*) (current-output-port *alt-log-file*))))) (if (and (server:read-dotserver *toppath*) (server:check-if-running run-id)) (begin (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") (exit 0)) (begin ;; ok, no server detected, clean out any lingering records (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding"))) (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) (begin (thread-sleep! 2) (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") (server:complete-attempt *toppath*) )) (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") "-") |
︙ | ︙ |
Modified launch.scm from [e1f9f3deb0] to [580823485a].
︙ | ︙ | |||
278 279 280 281 282 283 284 | ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. | | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 | ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (if (hash-table? testconfig) (hash-table-ref/default testconfig "ezsteps" '()) #f))) (if testconfig (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... (begin (launch:setup) |
︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 | (list "MT_TEST_NAME" test-name) (list "MT_RUNNAME" runname) (list "MT_ITEMPATH" item-path) ) itemdat)) (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed ;; for tconfig, why do we allow fallback to test-conf? | | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 | (list "MT_TEST_NAME" test-name) (list "MT_RUNNAME" runname) (list "MT_ITEMPATH" item-path) ) itemdat)) (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed ;; for tconfig, why do we allow fallback to test-conf? (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) (begin (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.") test-conf))) ;; force re-read now that all vars are set (useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell"))) (if ush (if (equal? ush "no") ;; must use "no" to NOT use shell #f |
︙ | ︙ |
Modified megatest-version.scm from [0bf6986bb1] to [2c08f91447].
1 2 3 4 5 | ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) | | | 1 2 3 4 5 6 7 | ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) (define megatest-version 1.6303) |
Modified megatest.scm from [e7342b90ae] to [ba3fdf979e].
︙ | ︙ | |||
347 348 349 350 351 352 353 | (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *watchdog* (make-thread common:watchdog "Watchdog thread")) | > | | > | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 | (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *watchdog* (make-thread common:watchdog "Watchdog thread")) (if (not (args:get-arg "-server")) (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog ;;(BB> "thread-start! watchdog") (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log")) (set! *default-log-port* oup))) (if (or (args:get-arg "-h") (args:get-arg "-help") |
︙ | ︙ | |||
1988 1989 1990 1991 1992 1993 1994 | ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 *default-log-port* help)) | | > > > > > > | > | 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 | ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 *default-log-port* help)) ;;(BB> "thread-join! watchdog") ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) (if (thread? *watchdog*) (case (thread-state *watchdog*) ((ready running blocked sleeping terminated dead) (thread-join! *watchdog*)))) (set! *time-to-exit* #t) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) |
Added minimal/manyservers.sh version [1fde698cb9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | #!/bin/bash echo manyservers.sh pid $$ logdir=$PWD/log-manysrv function reset { rm -f .homehost .server .server.lock links/.db/monitor.db .starting-server } function launch_many_servers { # count = $1 # logdir = $2 # prefx = $3 perl -e 'foreach my $i (1 ... '$1'){print "'$2'/'$3'-srv-$i.log\n"}' | \ xargs -P $1 -n 1 megatest -server - -run-id 0 -daemonize -log } function get_srv_pids { ps auwx | grep "mtest -server" | grep $logdir | grep -v grep | awk '{print $2}' } if [[ -e $logdir ]]; then rm -rf $logdir; fi if [[ ! -e $logdir ]]; then mkdir $logdir; fi reset simultaneous_servers=20 server_collision_resolution_delay=15 server_timeout_delay=65 echo "Launching $simultaneous_servers simultaneous servers" launch_many_servers $simultaneous_servers $logdir "first" echo "Sleeping $server_collision_resolution_delay seconds to allow new servers to die because one is already running." sleep $server_collision_resolution_delay pids=`get_srv_pids` pids_left=`echo $pids | wc -w` echo "pids_left=$pids_left" echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1" if [[ $pids_left == 1 ]]; then echo "All servers but 1 terminated. Still good." else if [[ $pids_left == 0 ]]; then echo "All servers died too soon. Not good. Aborting." echo "TEST FAIL" exit 1 else echo "Too many servers left. Not good. Aborting." echo "TEST FAIL" echo $pids | xargs kill sleep 5 pids=`get_srv_pids` pids_left=`echo $pids | wc -w` if [[ ! ( $pids_left == 0 ) ]]; then echo $pids | xargs kill -9 fi exit 1 fi fi echo "launching another volley of $simultaneous_servers. THey should all perish. right away, leaving the one server running." launch_many_servers $simultaneous_servers $logdir "second" sleep $server_collision_resolution_delay pids=`get_srv_pids` pids_left=`echo $pids | wc -w` echo "pids_left=$pids_left" echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1" if [[ $pids_left == 1 ]]; then echo "All servers but 1 terminated. So far so good." else if [[ $pids_left == 0 ]]; then echo "All servers died too soon. Not good. Aborting." echo "TEST FAIL" exit 1 else echo "Too many servers left. Not good. Aborting." echo "TEST FAIL" echo $pids | xargs kill sleep 5 pids=`get_srv_pids` pids_left=`echo $pids | wc -w` if [[ ! ( $pids_left == 0 ) ]]; then echo $pids | xargs kill -9 fi exit 1 fi fi echo "sleeping for awhile ($server_timeout_delay seconds) to let server exit on its own for no-request timeout" sleep $server_timeout_delay pids=`get_srv_pids` pids_left=`echo $pids | wc -w` echo "after $server_timeout_delay seconds: servers remaining=$pids_left; expecting 0" if [[ $pids_left == 0 ]]; then echo "No servers remain. This is good." echo "TEST PASS" exit 0 else echo "Too many servers left. Not good. Aborting." echo "TEST FAIL" echo $pids | xargs kill sleep 5 pids=`get_srv_pids` pids_left=`echo $pids | wc -w` if [[ ! ( $pids_left == 0 ) ]]; then echo $pids | xargs kill -9 fi exit 1 fi |
Modified rmt.scm from [c70f311cf0] to [b725604f3b].
︙ | ︙ | |||
29 30 31 32 33 34 35 | ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; | | | > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; (define (rmt:get-connection-info areapath) ;; TODO: push areapath down. (let ((cinfo (remote-conndat *runremote*)) (run-id 0)) (if cinfo cinfo (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id |
︙ | ︙ | |||
112 113 114 115 116 117 118 | ;; ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost ;; (not (member cmd api:read-only-queries))) ;; (mutex-unlock! *rmt-mutex*) ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") ;; (rmt:open-qry-close-locally cmd 0 params)) | | > | | | | < < | | | > > > > | | | | | > > | > > > > > > > > | | > | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | ;; ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost ;; (not (member cmd api:read-only-queries))) ;; (mutex-unlock! *rmt-mutex*) ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") ;; (rmt:open-qry-close-locally cmd 0 params)) ;; on homehost, no server contact made and this is a write, passively start a server ((and (cdr (remote-hh-dat *runremote*)) ; new (not (remote-server-url *runremote*)) (not (member cmd api:read-only-queries))) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5") (let ((server-url (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call (if server-url (remote-server-url-set! *runremote* server-url) ;; the string can be consumed by the client setup if needed (if (not (server:start-attempted? *toppath*)) (server:kind-run *toppath*)))) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1") (rmt:open-qry-close-locally cmd 0 params)) ;;; ;; (begin ;; not on homehost, start server and wait ;; (mutex-unlock! *rmt-mutex*) ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.2") ;; (tasks:start-and-wait-for-server (tasks:open-db) 0 15) ;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;) ;) ;;;; ;; if not on homehost ensure we have a connection to a live server ;; NOTE: we *have* a homehost record by now ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost (not (remote-conndat *runremote*)) ;; and no connection (server:read-dotserver *toppath*)) ;; .server file exists ;; something caused the server entry in tdb to disappear, but the server is still running (server:remove-dotserver-file *toppath* ".*") (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20") (rmt:send-receive cmd rid params attemptnum: (add1 attemptnum))) ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost (not (remote-conndat *runremote*))) ;; and no connection (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*)) (mutex-unlock! *rmt-mutex*) (tasks:start-and-wait-for-server (tasks:open-db) 0 15) (remote-conndat-set! *runremote* (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as ;; all set up if get this far, dispatch the query ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 7") (rmt:open-qry-close-locally cmd (if rid rid 0) params)) ;; not on homehost, do server query (else (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") (let* ((conninfo (remote-conndat *runremote*)) (dat (case (remote-transport *runremote*) ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away |
︙ | ︙ |
Modified rpc-transport.scm from [7aa56cfddc] to [f2b0cd0198].
︙ | ︙ | |||
174 175 176 177 178 179 180 | (port (cadr host-info)) (ping-res ((rpc:procedure 'server:login host port) *toppath*))) (if ping-res (let ((server-dat (list iface port #f #f #f))) (hash-table-set! *runremote* run-id server-dat) server-dat) (begin | | | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | (port (cadr host-info)) (ping-res ((rpc:procedure 'server:login host port) *toppath*))) (if ping-res (let ((server-dat (list iface port #f #f #f))) (hash-table-set! *runremote* run-id server-dat) server-dat) (begin (server:try-running *toppath*) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))) (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id))) (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-db-info (let* ((iface (tasks:hostinfo-get-interface server-db-info)) (port (tasks:hostinfo-get-port server-db-info)) (server-dat (list iface port #f #f #f)) (ping-res ((rpc:procedure 'server:login host port) *toppath*))) (if start-res (begin (hash-table-set! *runremote* run-id server-dat) server-dat) (begin (server:try-running *toppath*) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))) (begin (server:try-running *toppath*) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))))))) ;; ;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) ;; (if (and port ;; (string->number port)) ;; (let ((portn (string->number port))) |
︙ | ︙ |
Modified server.scm from [c0f30a061c] to [11f19c65b6].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras) ;; (use zmq) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) (declare (uses common)) |
︙ | ︙ | |||
45 46 47 48 49 50 51 | ;; ;; all routes though here end in exit ... ;; ;; start_server ;; (define (server:launch run-id transport-type) | | > > > > > > > > > > > > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | ;; ;; all routes though here end in exit ... ;; ;; start_server ;; (define (server:launch run-id transport-type) ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type) (let ((attempt-in-progress (server:start-attempted? *toppath*))) ; check for .server-starting (when attempt-in-progress (debug:print-info 0 *default-log-port* "Server start attempt in progress in other process (=> "attempt-in-progress"<=). Aborting server launch attempt in this process ("(current-process-id)")") (exit))) (let ((dotserver-url (server:check-if-running *toppath*))) ;; check for .server (when dotserver-url (debug:print-info 0 *default-log-port* "Server already running (=> "dotserver-url"<=). Aborting server launch attempt in this process ("(current-process-id)")") (exit) )) (case transport-type ((http)(http-transport:launch run-id)) ;;((nmsg)(nmsg-transport:launch run-id)) ((rpc) (rpc-transport:launch run-id)) (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))) ;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc") ;; (rpc-transport:launch run-id))))) |
︙ | ︙ | |||
101 102 103 104 105 106 107 | result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; | | > > | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | | | < | > | | | | > > > > > | > | > | > > > > > > | | | | > > > > > > > > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > | | | | > > | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 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 234 235 236 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 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 | result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; (define (server:run areapath) ;; areapath is *toppath* for a given testsuite area (let* ((curr-host (get-host-name)) (attempt-in-progress (server:start-attempted? areapath)) (dot-server-url (server:check-if-running areapath)) (curr-ip (server:get-best-guess-address curr-host)) (curr-pid (current-process-id)) (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) (testsuite (common:get-testsuite-name)) (logfile (conc areapath "/logs/server.log")) (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") (conc " -daemonize -log " logfile) "") " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &"))))) (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread"))) ;; we want the remote server to start in *toppath* so push there (push-directory areapath) (cond (attempt-in-progress (debug:print 0 *default-log-port* "INFO: Not trying to start server because attempt is in progress: "attempt-in-progress)) (dot-server-url (debug:print 0 *default-log-port* "INFO: Not trying to start server because one is already running : "dot-server-url)) (else (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") (thread-start! log-rotate) ;; host.domain.tld match host? (if (and target-host ;; look at target host, is it host.domain.tld or ip address and does it ;; match current ip or hostname (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) (thread-join! log-rotate) (pop-directory))))) (define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value. (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) (set! *my-client-signature* sig) *my-client-signature*))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run areapath) (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f))) (if (or (not last-run-time) (> (- (current-seconds) last-run-time) 30)) (begin (server:run areapath) (hash-table-set! *server-kind-run* areapath (current-seconds)))))) (define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. (define (server:attempting-start areapath) (with-output-to-file (conc areapath "/.starting-server") (lambda () (print (current-process-id) " on " (get-host-name))))) (define (server:complete-attempt areapath) (delete-file* (conc areapath "/.starting-server"))) (define (server:start-attempted? areapath) (let ((flagfile (conc areapath "/.starting-server"))) (handle-exceptions exn #f ;; if things go wrong pretend we can't see the file (cond ((and (file-exists? flagfile) (< (- (current-seconds) (file-modification-time flagfile)) 15)) ;; exists and less than 15 seconds old (with-input-from-file flagfile (lambda () (read-line)))) ((file-exists? flagfile) ;; it is stale. (server:complete-attempt areapath) #f) (else #f))))) (define (server:read-dotserver areapath) (let ((dotfile (conc areapath "/.server"))) (handle-exceptions exn #f ;; if things go wrong pretend we can't see the file (cond ((not (file-exists? dotfile)) #f) ((not (file-read-access? dotfile)) #f) ((> (server:dotserver-age-seconds areapath) (+ 5 (server:get-timeout))) (server:remove-dotserver-file areapath ".*") #f) (else (let* ((line (with-input-from-file dotfile (lambda () (read-line)))) (tokens (if (string? line) (string-split line ":") #f))) (cond ((eq? 4 (length tokens)) tokens) (else #f)))))))) (define (server:read-dotserver->url areapath) (let ((dotserver-tokens (server:read-dotserver areapath))) (if dotserver-tokens (conc (list-ref dotserver-tokens 0) ":" (list-ref dotserver-tokens 1)) #f))) ;; write a .server file in *toppath* with hostport ;; return #t on success, #f otherwise ;; (define (server:write-dotserver areapath host port pid transport) (let ((lock-file (conc areapath "/.server.lock")) (server-file (conc areapath "/.server"))) (if (common:simple-file-lock lock-file) (let ((res (handle-exceptions exn #f ;; failed for some reason, for the moment simply return #f (with-output-to-file server-file (lambda () (print (conc host ":" port ":" pid ":" transport)))) #t))) (debug:print-info 0 *default-log-port* "server file " server-file " for " host ":" port " created pid="pid) (common:simple-file-release-lock lock-file) res) #f))) ;; this will check that the .server file present matches the server calling this procedure. ;; if parameters match (this-pid and transport) the file will be touched and #t returned ;; otherwise #f will be returned. (define (server:confirm-dotserver areapath this-iface this-port this-pid this-transport) (let* ((tokens (server:read-dotserver areapath))) (cond ((not tokens) (debug:print-info 0 *default-log-port* "INFO: .server file does not exist.") #f) ((not (eq? 4 (length tokens))) (debug:print-info 0 *default-log-port* "INFO: .server file is corrupt. There are not 4 tokens as expeted; there are "(length tokens)".") #f) ((not (equal? this-iface (list-ref tokens 0))) (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for iface, server has value >"(list-ref tokens 0)"< but this server's value is >"this-iface"<") #f) ((not (equal? (->string this-port) (list-ref tokens 1))) (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for port, .server has value >"(list-ref tokens 1)"< but this server's value is >"(->string this-port)"<") #f) ((not (equal? (->string this-pid) (list-ref tokens 2))) (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for pid, .server has value >"(list-ref tokens 2)"< but this server's value is >"(->string this-pid)"<") #f) ((not (equal? (->string this-transport) (->string (list-ref tokens 3)))) (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for transport, .server has value >"(list-ref tokens 3)"< but this server's value is >"this-transport"<") #f) (else (server:touch-dotserver areapath) #t)))) (define (server:touch-dotserver areapath) (let ((server-file (conc areapath "/.server"))) (change-file-times server-file (current-seconds) (current-seconds)))) (define (server:dotserver-age-seconds areapath) (let ((server-file (conc areapath "/.server"))) (begin (handle-exceptions exn #f (- (current-seconds) (file-modification-time server-file)))))) (define (server:remove-dotserver-file areapath hostport) (let ((dotserver-url (server:read-dotserver->url areapath)) (server-file (conc areapath "/.server")) (lock-file (conc areapath "/.server.lock"))) (if (and dotserver-url (string-match (conc ".*:" hostport "$") dotserver-url)) ;; port matches, good enough info to decide to remove the file (if (common:simple-file-lock lock-file) (begin (handle-exceptions exn #f (delete-file* server-file)) (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed") (common:simple-file-release-lock lock-file)) (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - could not get lock.")) (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - dotserver-url("dotserver-url") did not match hostport pattern ("hostport")")))) ;; no longer care if multiple servers are started by accident. older servers will drop off in time. ;; (define (server:check-if-running areapath) (let* ((dotserver-url (server:read-dotserver->url areapath))) ;; tdbdat (tasks:open-db))) (if dotserver-url (let* ((res (case *transport-type* ((http)(server:ping-server dotserver-url)) ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) ))) (if res dotserver-url (begin (server:remove-dotserver-file areapath ".*") ;; remove stale dotserver #f))) #f))) ;; called in megatest.scm, host-port is string hostname:port ;; ;; NOTE: This is NOT called directly from clients as not all transports support a client running ;; in the same process as the server. ;; (define (server:ping host-port-in #!key (do-exit #f)) (let ((host:port (if (not host-port-in) ;; use read-dotserver to find (server:read-dotserver->url *toppath*) (if (number? host-port-in) ;; we were handed a server-id (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in))) ;; (print "srec: " srec " host-port-in: " host-port-in) (if srec (conc (vector-ref srec 3) ":" (vector-ref srec 4)) (conc "no such server-id " host-port-in))) host-port-in)))) |
︙ | ︙ |
Modified tasks.scm from [f1c7a9fde2] to [a0c6ff1ee2].
︙ | ︙ | |||
400 401 402 403 404 405 406 | (delay-time 0)) (if (and (not server-dat) (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) (debug:print 0 *default-log-port* "Try starting server for run-id " run-id)) (thread-sleep! (/ (random 2000) 1000)) | | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | (delay-time 0)) (if (and (not server-dat) (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) (debug:print 0 *default-log-port* "Try starting server for run-id " run-id)) (thread-sleep! (/ (random 2000) 1000)) (server:kind-run *toppath*) (thread-sleep! (min delay-time 1)) (if (not (or (server:start-attempted? *toppath*) (server:read-dotserver *toppath*))) ;; no point in trying (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)) #f)) #f))) |
︙ | ︙ |
Modified tests.scm from [63786038c0] to [99a08e573f].
︙ | ︙ | |||
139 140 141 142 143 144 145 | (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated ;; returns waitons waitors tconfigdat ;; (define (tests:get-waitons test-name all-tests-registry) | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated ;; returns waitons waitors tconfigdat ;; (define (tests:get-waitons test-name all-tests-registry) (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") (exit 1)))) (instr2 (if config (config-lookup config "requirements" "waitor") |
︙ | ︙ | |||
289 290 291 292 293 294 295 | (loop (car tal)(cdr tal)(cons qry res))))))) #f)) ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | (loop (car tal)(cdr tal)(cons qry res))))))) #f)) ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)) (test-rundir ;; (sdb:qry 'passstr (db:test-get-rundir testdat)) ;; ) (prev-rundir ;; (sdb:qry 'passstr (db:test-get-rundir prev-testdat)) ;; ) (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") |
︙ | ︙ | |||
977 978 979 980 981 982 983 | #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; | | | > > > | | | 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 | #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; (define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)) (let* ((cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read (file-exists? cache-file))) (cached-dat (if (and (not force-create) cache-exists) (handle-exceptions exn #f ;; any issues, just give up with the cached version and re-read (configf:read-alist cache-file)) #f)) (test-full-name (if (and item-path (not (string-null? item-path))) (conc test-name "/" item-path) test-name))) (if cached-dat cached-dat (let ((dat (hash-table-ref/default *testconfigs* test-full-name #f))) (if (and dat ;; have a locally cached version (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data? dat ;; no cached data available (let* ((treg (or test-registry (tests:get-all))) (test-path (or (hash-table-ref/default treg test-name #f) (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (configf:write-alist tcfg tpath))) tcfg)))))) |
︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 | ;; hed is the test name ;; test-records is a hash of test-name => test record (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") | > | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 | ;; hed is the test name ;; test-records is a hash of test-name => test record (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") ;; don't know item-path at this time, let the testconfig get the top level testconfig (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) (debug:print-info 8 *default-log-port* "waitons string is " instr) (string-split (cond |
︙ | ︙ |