︙ | | | ︙ | |
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
(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:check-if-running *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
|
|
|
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
(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 #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
|
︙ | | | ︙ | |
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
(conc megatest-version "-" megatest-fossil-hash))
(define (common:version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
(rmt:get-var "MEGATEST_VERSION"))
(define (common:get-last-run-version-number)
(string->number
(substring (common:get-last-run-version) 0 6)))
(define (common:set-last-run-version)
(rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
(define (common:version-changed?)
(not (equal? (common:get-last-run-version)
(common:version-signature))))
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
|
|
|
|
|
|
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
(conc megatest-version "-" megatest-fossil-hash))
(define (common:version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version area-dat) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
(rmt:get-var area-dat "MEGATEST_VERSION"))
(define (common:get-last-run-version-number)
(string->number
(substring (common:get-last-run-version) 0 6)))
(define (common:set-last-run-version area-dat)
(rmt:set-var area-dat "MEGATEST_VERSION" (common:version-signature)))
(define (common:version-changed?)
(not (equal? (common:get-last-run-version)
(common:version-signature))))
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
|
︙ | | | ︙ | |
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
|
(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))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
(if *task-db*
(let ((db (cdr *task-db*)))
(if (sqlite3:database? db)
(begin
(sqlite3:interrupt! db)
|
|
|
|
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
|
(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 area-dat)
(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))
(rmt:print-db-stats area-dat))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
(if *task-db*
(let ((db (cdr *task-db*)))
(if (sqlite3:database? db)
(begin
(sqlite3:interrupt! db)
|
︙ | | | ︙ | |
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
|
(define (common:args-get-state)
(or (args:get-arg "-state")(args:get-arg ":state")))
(define (common:args-get-status)
(or (args:get-arg "-status")(args:get-arg ":status")))
(define (common:args-get-testpatt rconf)
(let* ((tagexpr (args:get-arg "-tagexpr"))
(tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
(testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(cond
(tags-testpatt
(debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
tags-testpatt)
|
|
|
|
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
|
(define (common:args-get-state)
(or (args:get-arg "-state")(args:get-arg ":state")))
(define (common:args-get-status)
(or (args:get-arg "-status")(args:get-arg ":status")))
(define (common:args-get-testpatt area-dat rconf)
(let* ((tagexpr (args:get-arg "-tagexpr"))
(tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags area-dat tagexpr) ",") #f))
(testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(cond
(tags-testpatt
(debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
tags-testpatt)
|
︙ | | | ︙ | |
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
|
(let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
(eq? res 0)))
;; ideally put all this info into the db, no need to preserve it across moving homehost
;;
;; return list of
;; ( reachable? cpuload update-time )
(define (common:get-host-info hostname)
(let* ((loadinfo (rmt:get-latest-host-load hostname))
(load (car loadinfo))
(load-sample-time (cdr loadinfo))
(load-sample-age (- (current-seconds) load-sample-time))
(loadinfo-timeout-seconds 20)
(host-last-update-timeout-seconds 10)
(host-rec (hash-table-ref/default *host-loads* hostname #f))
)
|
|
|
|
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
|
(let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
(eq? res 0)))
;; ideally put all this info into the db, no need to preserve it across moving homehost
;;
;; return list of
;; ( reachable? cpuload update-time )
(define (common:get-host-info hostname area-dat)
(let* ((loadinfo (rmt:get-latest-host-load area-dat hostname))
(load (car loadinfo))
(load-sample-time (cdr loadinfo))
(load-sample-age (- (current-seconds) load-sample-time))
(loadinfo-timeout-seconds 20)
(host-last-update-timeout-seconds 10)
(host-rec (hash-table-ref/default *host-loads* hostname #f))
)
|
︙ | | | ︙ | |