︙ | | | ︙ | |
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
|
((skip)
(launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
;; NB// test-set-status! does rdb calls under the hood
(tests:test-set-status! run-id test-id next-state "SKIP"
(if (eq? this-step-status 'skip) "Logpro skip found" #f)
#f))
((pass)
(tests:test-set-status! run-id test-id next-state "PASS" #f #f))
(else ;; 'fail
(launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
(tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
)))
logpro-used))
(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
;; (let-values
;; (((pid exit-status exit-code)
;; (run-n-wait fullrunscript)))
;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
;; Since we should have a clean slate at this time there is no need to do
;; any of the other stuff that tests:test-set-status! does. Let's just
;; force RUNNING/n/a
;; (thread-sleep! 0.3)
;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
(rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f)
;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
;; if there is a runscript do it first
(if fullrunscript
(let ((pid (process-run fullrunscript)))
(rmt:test-set-top-process-pid run-id test-id pid)
|
>
>
|
>
>
|
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
|
((skip)
(launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
;; NB// test-set-status! does rdb calls under the hood
(tests:test-set-status! run-id test-id next-state "SKIP"
(if (eq? this-step-status 'skip) "Logpro skip found" #f)
#f))
((pass)
(tests:test-set-status! run-id test-id next-state "PASS" #f #f))
(else ;; 'fail
(launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
(tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
))
(set! *launch:execute:needs-cleanup* #f))
logpro-used))
(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
;; (let-values
;; (((pid exit-status exit-code)
;; (run-n-wait fullrunscript)))
;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
;; Since we should have a clean slate at this time there is no need to do
;; any of the other stuff that tests:test-set-status! does. Let's just
;; force RUNNING/n/a
;; (thread-sleep! 0.3)
;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
(set! *launch:execute:needs-cleanup* #t)
(rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f)
;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
;; if there is a runscript do it first
(if fullrunscript
(let ((pid (process-run fullrunscript)))
(rmt:test-set-top-process-pid run-id test-id pid)
|
︙ | | | ︙ | |
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
|
(if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
(loop (calc-minutes)
(or new-cpu-load cpu-load)
(or new-disk-free disk-free)
(if do-sync (current-seconds) last-sync)))))))
(tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
(setenv "MT_CMDINFO" encoded-cmd)
;;(bb-check-path msg: "launch:execute incoming")
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
|
|
|
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
|
(if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
(loop (calc-minutes)
(or new-cpu-load cpu-load)
(or new-disk-free disk-free)
(if do-sync (current-seconds) last-sync)))))))
(tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
(define *launch:execute:needs-cleanup* #f)
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
(setenv "MT_CMDINFO" encoded-cmd)
;;(bb-check-path msg: "launch:execute incoming")
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
|
︙ | | | ︙ | |
481
482
483
484
485
486
487
488
489
490
491
492
493
494
|
;; (transport (assoc/default 'transport cmdinfo)) ;; not used
;; (serverinf (assoc/default 'serverinf cmdinfo))
;; (port (assoc/default 'port cmdinfo))
(serverurl (assoc/default 'serverurl cmdinfo))
(homehost (assoc/default 'homehost cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(target (assoc/default 'target cmdinfo))
(areaname (assoc/default 'areaname cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(env-ovrd (assoc/default 'env-ovrd cmdinfo))
(set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar
(runname (assoc/default 'runname cmdinfo))
(megatest (assoc/default 'megatest cmdinfo))
|
>
>
>
|
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
|
;; (transport (assoc/default 'transport cmdinfo)) ;; not used
;; (serverinf (assoc/default 'serverinf cmdinfo))
;; (port (assoc/default 'port cmdinfo))
(serverurl (assoc/default 'serverurl cmdinfo))
(homehost (assoc/default 'homehost cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(cleanup-thunk (lambda ()
(if *launch:execute:needs-cleanup*
(rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" "either explicitly killed or other test execution abort failure"))))
(target (assoc/default 'target cmdinfo))
(areaname (assoc/default 'areaname cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(env-ovrd (assoc/default 'env-ovrd cmdinfo))
(set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar
(runname (assoc/default 'runname cmdinfo))
(megatest (assoc/default 'megatest cmdinfo))
|
︙ | | | ︙ | |
574
575
576
577
578
579
580
581
582
583
584
585
586
587
|
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(if (eq? signum signal/stop)
(debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
(rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f)
(print "Killed by signal " signum ". Exiting")
(thread-sleep! 1)
(exit 1))))
(th2 (make-thread (lambda ()
(thread-sleep! 2)
(debug:print 0 *default-log-port* "Done")
(exit 4)))))
|
>
|
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
|
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(if (eq? signum signal/stop)
(debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
(rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f)
(set! *launch:execute:needs-cleanup* #f)
(print "Killed by signal " signum ". Exiting")
(thread-sleep! 1)
(exit 1))))
(th2 (make-thread (lambda ()
(thread-sleep! 2)
(debug:print 0 *default-log-port* "Done")
(exit 4)))))
|
︙ | | | ︙ | |
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
(exit))))
(test-pid (db:test-get-process_id test-info)))
(cond
;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
(exit)))
((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
)
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(exit))))
(debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
|
>
>
>
|
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
|
(exit))))
(test-pid (db:test-get-process_id test-info)))
(cond
;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
;;BB(set! *time-to-exit-cleanup-thunk-list*
(set! *launch:execute:needs-cleanup* #t)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
(exit)))
((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(set! *launch:execute:needs-cleanup* #t)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
)
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(exit))))
(debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
|
︙ | | | ︙ | |
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
|
(begin
(debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
(runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
;; prevent overlapping actions - set to LAUNCHED as early as possible
;;
;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail
(tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f)
;; (pp (hash-table->alist tconfig))
(set! diskpath (get-best-disk *configdat* tconfig))
(if diskpath
(let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
(set! work-area (car dat))
|
>
|
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
|
(begin
(debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
(runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
;; prevent overlapping actions - set to LAUNCHED as early as possible
;;
;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail
(set! *launch:execute:needs-cleanup* #t)
(tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f)
;; (pp (hash-table->alist tconfig))
(set! diskpath (get-best-disk *configdat* tconfig))
(if diskpath
(let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
(set! work-area (car dat))
|
︙ | | | ︙ | |
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
|
(conc cmdstr " >> mt_launch.log 2>&1 &")))
(car fullcmd))
(if useshell
'()
(cdr fullcmd))))
(success (if launchwait (equal? 0 (cadr launch-results-prev)) #t))
(launch-results (if launchwait (car launch-results-prev) launch-results-prev)))
(if (not success)
(tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED"))
(mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test
(if (not launchwait) ;; give the OS a little time to allow the process to start
(thread-sleep! 0.01))
(with-output-to-file "mt_launch.log"
(lambda ()
(print "LAUNCHCMD: " (string-intersperse fullcmd " "))
|
|
|
>
|
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
|
(conc cmdstr " >> mt_launch.log 2>&1 &")))
(car fullcmd))
(if useshell
'()
(cdr fullcmd))))
(success (if launchwait (equal? 0 (cadr launch-results-prev)) #t))
(launch-results (if launchwait (car launch-results-prev) launch-results-prev)))
(when (not success)
(tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)
(set! *launch:execute:needs-cleanup* #f)) ;; (if launch-results launch-results "FAILED"))
(mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test
(if (not launchwait) ;; give the OS a little time to allow the process to start
(thread-sleep! 0.01))
(with-output-to-file "mt_launch.log"
(lambda ()
(print "LAUNCHCMD: " (string-intersperse fullcmd " "))
|
︙ | | | ︙ | |