︙ | | | ︙ | |
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
|
(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.
;;
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define *watchdog* (make-thread
(lambda ()
(handle-exceptions
exn
(begin
(print-call-chain)
(print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
(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
(let* ((no-watchdog-args
'("-list-runs"
"-testdata-csv"
"-list-servers"
|
|
|
|
|
|
|
|
|
|
|
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
|
(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.
;;
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;(define *watchdog* (make-thread
;; (lambda ()
;; (handle-exceptions
;; exn
;; (begin
;; (print-call-chain)
;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
;; (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
(let* ((no-watchdog-args
'("-list-runs"
"-testdata-csv"
"-list-servers"
|
︙ | | | ︙ | |
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
|
(if (null? tail)
#t
(loop (car tail) (cdr tail))))))
(no-watchdog-args-vals (filter (lambda (x) x)
(map args:get-arg no-watchdog-args)))
(start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog)
(if start-watchdog
(thread-start! *watchdog*)))
;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
(condition-case
(let* ((log-dir (or (pathname-directory logpath-in) "."))
(fname (pathname-strip-directory logpath-in))
|
|
|
>
>
|
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
|
(if (null? tail)
#t
(loop (car tail) (cdr tail))))))
(no-watchdog-args-vals (filter (lambda (x) x)
(map args:get-arg no-watchdog-args)))
(start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog)
;; (if start-watchdog
;; (thread-start! *watchdog*))
#t
)
;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
(condition-case
(let* ((log-dir (or (pathname-directory logpath-in) "."))
(fname (pathname-strip-directory logpath-in))
|
︙ | | | ︙ | |
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
|
(when (args:get-arg "-sync-brute-force")
(launch:setup)
((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
(set! *didsomething* #t))
(if (args:get-arg "-sync-to-megatest.db")
(let* ((duh (launch:setup))
(dbstruct (db:setup #f))
(tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
(res (if locked
(db:multi-db-sync
dbstruct
'new2old)
#f)))
|
|
|
|
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
|
(when (args:get-arg "-sync-brute-force")
(launch:setup)
((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
(set! *didsomething* #t))
(if (args:get-arg "-sync-to-megatest.db")
(let* ((duh (launch:setup))
(dbstruct (db:setup #t))
(tmpdbpth (dbr:dbstruct-tmppath dbstruct))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
(res (if locked
(db:multi-db-sync
dbstruct
'new2old)
#f)))
|
︙ | | | ︙ | |
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
|
(set! *time-to-exit* #t)
)
;;(debug:print-info 13 *default-log-port* "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)
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(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)))))
|
|
|
|
|
|
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
|
(set! *time-to-exit* #t)
)
;;(debug:print-info 13 *default-log-port* "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)
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;(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)))))
|