455
456
457
458
459
460
461
462
463
464
465
466
467
468
|
;;
(define (server:writable-watchdog dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(no-sync-db (db:open-no-sync-db))
(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))))
(set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
(debug:print-info 2 *default-log-port* "Periodic sync thread started.")
(debug:print-info 3 *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))
(mtdb (dbr:dbstruct-mtdb dbstruct))
|
>
|
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
|
;;
(define (server:writable-watchdog dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(no-sync-db (db:open-no-sync-db))
(sync-duration 0) ;; run time of the sync in milliseconds
(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))))
(set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
(debug:print-info 2 *default-log-port* "Periodic sync thread started.")
(debug:print-info 3 *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))
(mtdb (dbr:dbstruct-mtdb dbstruct))
|
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
|
(not recently-synced))))
(debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync)
;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
(if will-sync (set! *db-sync-in-progress* #t))
(mutex-unlock! *db-multi-sync-mutex*)
(if will-sync
(let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
(if (> res 0) ;; some records were transferred, keep the db alive
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)
(debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
(debug:print-info 2 *default-log-port* "sync called but zero records transferred"))))
|
>
>
|
>
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
|
(not recently-synced))))
(debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync)
;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
(if will-sync (set! *db-sync-in-progress* #t))
(mutex-unlock! *db-multi-sync-mutex*)
(if will-sync
(let ((sync-start (current-milliseconds)))
(if (< sync-duration 300)
(let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
(set! sync-duration (- (current-milliseconds) sync-start))
(if (> res 0) ;; some records were transferred, keep the db alive
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)
(debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
(debug:print-info 2 *default-log-port* "sync called but zero records transferred")))
;; TODO: factor this next routine out into a function
(with-input-from-pipe ;; this should not block other threads but need to verify this
"megatest -sync-to-megatest.db"
(lambda ()
(let loop ((inl (read-line))
(res #f))
(if (eof-object? inl)
(begin
(set! sync-duration (- (current-milliseconds) sync-start))
(cond
((not res)
(debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\""))
((> res 0)
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))))
(let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl)))
(if matches
(string->number (cadr matches))
#f))))
(loop (read-line)
(or num-synced res))))))))))
(if will-sync
(begin
(mutex-lock! *db-multi-sync-mutex*)
(set! *db-sync-in-progress* #f)
(set! *db-last-sync* start-time)
(mutex-unlock! *db-multi-sync-mutex*)))
(if (and debug-mode
|