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
|
;;======================================================================
;; 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.
;;======================================================================
(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack)
(require-extension regex posix)
(require-extension (srfi 18) extras tcp rpc)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
;;
;; (define (exit . code)
;; (if (null? code)
;; (old-exit)
;; (old-exit code)))
(define getenv get-environment-variable)
(define (safe-setenv key val)
(if (and (string? val)(string? key))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
(setenv key val))
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))
(define *contexts* (make-hash-table))
(define *context-mutex* (make-mutex))
;; safe method for accessing a context given a toppath
;;
(define (common:with-cxt toppath proc)
(mutex-lock! *context-mutex*)
(let ((cxt (hash-table-ref/default *contexts* toppath #f)))
(if (not cxt)
(set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
(let ((cxt-mutex (cxt-mutex cxt)))
(mutex-unlock! *context-mutex*)
(mutex-lock! cxt-mutex)
(let ((res (proc cxt)))
(mutex-unlock! cxt-mutex)
res))))
(define *db-keys* #f)
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
(define *alt-log-file* #f) ;; used by -log
(define *common:denoise* (make-hash-table)) ;; for low noise printing
(define *default-log-port* (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
;; DATABASE
(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
|
|
|
<
<
>
>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
|
|
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
|
;;======================================================================
;; 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.
;;======================================================================
(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack
matchable regex posix srfi-18 extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
;;
;; (define (exit . code)
;; (if (null? code)
;; (old-exit)
;; (old-exit code)))
(define getenv get-environment-variable)
(define (safe-setenv key val)
(if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
(if (and (string? val)
(string? key))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
(setenv key val))
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
;; CONTEXTS
(defstruct cxt
(taskdb #f)
(cmutex (make-mutex)))
;; (define *contexts* (make-hash-table))
;; (define *context-mutex* (make-mutex))
;; ;; safe method for accessing a context given a toppath
;; ;;
;; (define (common:with-cxt toppath proc)
;; (mutex-lock! *context-mutex*)
;; (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
;; (if (not cxt)
;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
;; (let ((cxt-mutex (cxt-mutex cxt)))
;; (mutex-unlock! *context-mutex*)
;; (mutex-lock! cxt-mutex)
;; (let ((res (proc cxt)))
;; (mutex-unlock! cxt-mutex)
;; res))))
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))
(define *db-keys* #f)
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f) ;; used by -log
(define *common:denoise* (make-hash-table)) ;; for low noise printing
(define *default-log-port* (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
;; DATABASE
(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
|
| ︙ | | | ︙ | |
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
(define *db-with-db-mutex* (make-mutex))
(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* #f) ;; if set up for server communication this will hold <host port>
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
(define *server-run* #t)
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *home-host* #f)
(define *total-non-write-delay* 0)
(define *heartbeat-mutex* (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
|
|
|
|
|
|
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
(define *db-with-db-mutex* (make-mutex))
(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* #f) ;; if set up for server communication this will hold <host port>
;; (define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
;; (define *server-id* #f)
(define *server-info* #f) ;; good candidate for easily convert to non-global
(define *time-to-exit* #f)
(define *server-run* #t)
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *home-host* #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex* (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
|
| ︙ | | | ︙ | |
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
(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
(reachable #f)
(last-update 0)
(last-used 0)
(last-cpuload 1))
|
|
>
>
>
|
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
(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 (server:get-timeout)) ;; default from server:get-timeout
(force-server #f)
(ro-mode #f)
(ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode
;; launching and hosts
(defstruct host
(reachable #f)
(last-update 0)
(last-used 0)
(last-cpuload 1))
|
| ︙ | | | ︙ | |
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct)
(db:multi-db-sync
dbstruct
;; 'new2old
'killservers
'dejunk
;; 'adj-testids
;; 'old2new
'new2old
'schema)
|
>
|
<
>
|
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct)
(db:multi-db-sync
dbstruct
'schema
;; 'new2old
'killservers
'dejunk
'adj-target
;; 'old2new
'new2old
)
(if (common:version-changed?)
(common:set-last-run-version)))
;; Rotate logs, logic:
;; if > 500k and older than 1 week:
;; remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the
|
| ︙ | | | ︙ | |
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
|
exn
#f
(delete-file fullname)))))))
'()
"logs"))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
(if (common:version-changed?)
(if (common:on-homehost?)
(let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
(dbstruct (db:setup)))
(if (and (file-exists? mtconf)
(eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
(begin
(debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "Failed to switch versions.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
(exit 1))
(common:cleanup-db dbstruct)))
(begin
(debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
(exit 1))))
(begin
(debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
(exit 1)))))
|
>
<
|
>
|
>
>
|
>
>
|
|
<
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
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
|
exn
#f
(delete-file fullname)))))))
'()
"logs"))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;; Do NOT check if not on homehost!
;;
(define (common:exit-on-version-changed)
(if (common:on-homehost?)
(if (common:version-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
(dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
(read-only (not (file-write-access? dbfile)))
(dbstruct (db:setup #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
((and (file-exists? mtconf) (file-exists? dbfile) (not read-only)
(eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
(debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "Failed to switch versions.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
(exit 1))
(common:cleanup-db dbstruct)))
((not (file-exists? mtconf))
(debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.")
(exit 1))
((not (file-exists? dbfile))
(debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.")
(exit 1))
((not (eq? (current-user-id)(file-owner mtconf)))
(debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.")
(exit 1))
(read-only
(debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.")
(exit 1))
(else
(debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
(exit 1)))))
(begin
(debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
(exit 1))))
;;======================================================================
;; S P A R S E A R R A Y S
;;======================================================================
(define (make-sparse-array)
(let ((a (make-sparse-vector)))
|
| ︙ | | | ︙ | |
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
419
420
421
422
|
(read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(if (file-exists? fname)
(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
(begin
(delete-file* fname)
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
(thread-sleep! 0.25)
(if (file-exists? fname)
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line))))
#f))))
(define (common:simple-file-release-lock fname)
(delete-file* fname))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
'((0 "ARCHIVED")
|
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
416
417
418
419
420
421
422
423
424
425
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
|
(read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(handle-exceptions
exn
#f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail.
(if (file-exists? fname)
(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
(begin
(delete-file* fname)
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
(thread-sleep! 0.25)
(if (file-exists? fname)
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line))))
#f)))))
(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
(let ((end-time (+ expire-time (current-seconds))))
(let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
(if got-lock
#t
(if (> end-time (current-seconds))
(begin
(thread-sleep! 3)
(loop (common:simple-file-lock fname expire-time: expire-time)))
#f)))))
(define (common:simple-file-release-lock fname)
(handle-exceptions
exn
#f ;; I don't really care why this failed (at least for now)
(delete-file* fname)))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
'((0 "ARCHIVED")
|
| ︙ | | | ︙ | |
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
|
(8 "RUNNING")
))
(define *common:std-statuses*
'(;; (0 "DELETED")
(1 "n/a")
(2 "PASS")
(3 "CHECK")
(4 "SKIP")
(5 "WARN")
(6 "WAIVED")
|
<
|
|
|
>
|
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
|
(8 "RUNNING")
))
(define *common:std-statuses*
'(;; (0 "DELETED")
(1 "n/a")
(2 "PASS")
(3 "SKIP")
(4 "WARN")
(5 "WAIVED")
(6 "CHECK")
(7 "STUCK/DEAD")
(8 "FAIL")
(9 "ABORT")))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
|
| ︙ | | | ︙ | |
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
|
(if val val default)))
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "testsuite" )
(if *toppath*
(pathname-file *toppath*)
(pathname-file (current-directory)))))
(define (common:get-db-tmp-area)
(if *db-cache-path*
*db-cache-path*
(let ((dbpath (create-directory (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")) #t)))
(set! *db-cache-path* dbpath)
dbpath)))
|
>
|
>
|
|
>
>
>
|
|
|
|
|
|
>
>
>
>
|
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
|
(if val val default)))
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
(getenv "MT_TESTSUITE_NAME")
(if (string? *toppath* )
(pathname-file *toppath*)
#f))) ;; (pathname-file (current-directory)))))
(define common:get-area-name common:get-testsuite-name)
(define (common:get-db-tmp-area)
(if *db-cache-path*
*db-cache-path*
(if *toppath*
(let ((dbpath (create-directory (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")) #t)))
(set! *db-cache-path* dbpath)
dbpath)
#f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
(define (common:run-sync?)
(and (common:on-homehost?)
(args:get-arg "-server")))
|
| ︙ | | | ︙ | |
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
|
(define *wdnum* 0)
(define *wdnum*mutex (make-mutex))
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
(define (common:watchdog)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))))
(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))
(mtpath (db:dbdat-get-path mtdb)))
(debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
(let loop ()
;; 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
(start-time (current-seconds))
(mt-mod-time (file-modification-time mtpath))
(recently-synced (> (- start-time mt-mod-time) 4))
(will-sync (and (or need-sync should-sync)
(not sync-in-progress)
(not recently-synced))))
;; (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 (common:sync-to-megatest.db dbstruct))) ;; 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
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
>
|
634
635
636
637
638
639
640
641
642
643
644
645
646
647
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
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
|
(define *wdnum* 0)
(define *wdnum*mutex (make-mutex))
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
(define (common:readonly-watchdog dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
;; sync megatest.db to /tmp/.../megatst.db
(let* ((sync-cool-off-duration 3)
(golden-mtdb (dbr:dbstruct-mtdb dbstruct))
(golden-mtpath (db:dbdat-get-path golden-mtdb))
(tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
(tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
(debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
(let loop ((last-sync-time 0))
(debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
(let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
(debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
(if (and (not *time-to-exit*)
(< duration-since-last-sync sync-cool-off-duration))
(thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
(if (not *time-to-exit*)
(let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
(tmp-mtdb-mtime (file-modification-time tmp-mtpath)))
(if (> golden-mtdb-mtime tmp-mtdb-mtime)
(let ((res (db:multi-db-sync dbstruct 'old2new)))
(debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))
(loop (current-seconds)))
#t)))
(debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
(define (common: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))
(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))))
(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))
(mtpath (db:dbdat-get-path mtdb)))
(debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
(let loop ()
;; 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
(start-time (current-seconds))
(mt-mod-time (file-modification-time mtpath))
(recently-synced (< (- start-time mt-mod-time) 4))
(will-sync (and (or need-sync should-sync)
(not sync-in-progress)
(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 (common:sync-to-megatest.db dbstruct))) ;; 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
|
| ︙ | | | ︙ | |
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
|
(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))
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
|
(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))
;;(debug:print-info 13 *default-log-port* "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)))))))
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define (common:watchdog)
(debug:print-info 13 *default-log-port* "common:watchdog entered.")
(if (common:on-homehost?)
(let ((dbstruct (db:setup #t)))
(debug:print-info 13 *default-log-port* "after db:setup with dbstruct="dbstruct)
(cond
((dbr:dbstruct-read-only dbstruct)
(debug:print-info 13 *default-log-port* "loading read-only watchdog")
(common:readonly-watchdog dbstruct))
(else
(debug:print-info 13 *default-log-port* "loading writable-watchdog.")
(common:writable-watchdog dbstruct)))
(debug:print-info 13 *default-log-port* "watchdog done."))
(debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))
(define (std-exit-procedure)
(on-exit (lambda () 0))
;;(debug:print-info 13 *default-log-port* "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))
|
| ︙ | | | ︙ | |
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
|
)
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!
;;======================================================================
;; M I S C U T I L S
;;======================================================================
;; one-of args defined
(define (args-defined? . param)
(let ((res #f))
(for-each
(lambda (arg)
(if (args:get-arg arg)(set! res #t)))
param)
res))
|
|
<
<
<
<
<
<
<
<
<
|
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
|
)
0)
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
;;(debug:print-info 13 *default-log-port* "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!
;;======================================================================
;; M I S C U T I L S
;;======================================================================
;; convert stuff to a number if possible
(define (any->number val)
(cond
((number? val) val)
((string? val) (string->number val))
((symbol? val) (any->number (symbol->string val)))
(else #f)))
|
| ︙ | | | ︙ | |
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
|
(debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt)
(if (string-match (regexp modpatt) item)
(set! res #t))))
(string-split patts ","))
res)
#t))
;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
(define (common:get-runconfig-targets #!key (configf #f))
(let ((targs (sort (map car (hash-table->alist
(or configf
(read-config (conc *toppath* "/runconfigs.config")
#f #t)
(make-hash-table))))
string<?))
(target-patt (args:get-arg "-target")))
(if target-patt
(filter (lambda (x)
(patt-list-match x target-patt))
targs)
targs)))
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
838
839
840
841
842
843
844
845
846
847
848
849
850
851
|
(debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt)
(if (string-match (regexp modpatt) item)
(set! res #t))))
(string-split patts ","))
res)
#t))
;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks #!key (configf #f))
(hash-table-ref/default
(or configf (read-config "megatest.config" #f #t))
"disks" '("none" "")))
;; return first command that exists, else #f
|
| ︙ | | | ︙ | |
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
|
(create-directory hed #t)))))
(if (and (string? res)
(directory? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(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)
((and (equal? args-testpatt "%") rtestpatt)
(debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
rtestpatt)
(else args-testpatt))))
(configf:lookup *configdat* "setup" "linktree"))))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:args-get-target #!key (split #f))
(let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
(null? (filter string-null? tlist))))
#f)))
(if valid
(if split
tlist
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
#f)
#f))))
;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
(define (common:get-homehost #!key (trynum 5))
;; called often especially at start up. use mutex to eliminate collisions
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
|
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
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
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
|
(create-directory hed #t)))))
(if (and (string? res)
(directory? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
;; return the youngest timestamp . filename
;;
(define (common:get-youngest glob-list)
(let ((all-files (apply append
(map (lambda (patt)
(handle-exceptions
exn
'()
(glob patt)))
glob-list))))
(fold (lambda (fname res)
(let ((last-mod (car res))
(curmod (handle-exceptions
exn
0
(file-modification-time fname))))
(if (> curmod last-mod)
(list curmod fname)
res)))
'(0 "n/a")
all-files)))
;; use bash to expand a glob. Does NOT handle paths with spaces!
;;
(define (common:bash-glob instr)
(string-split
(with-input-from-pipe
(conc "/bin/bash -c \"echo " instr "\"")
read-line)))
;;======================================================================
;; T A R G E T S , S T A T E , S T A T U S ,
;; R U N N A M E A N D T E S T P A T T
;;======================================================================
;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
;;
(define (common:get-runconfig-targets #!key (configf #f))
(let ((targs (sort (map car (hash-table->alist
(or configf ;; NOTE: There is no value in using runconfig:read here.
(read-config (conc *toppath* "/runconfigs.config")
#f #t)
(make-hash-table))))
string<?))
(target-patt (args:get-arg "-target")))
(if target-patt
(filter (lambda (x)
(patt-list-match x target-patt))
targs)
targs)))
;; Lookup a value in runconfigs based on -reqtarg or -target
;;
(define (runconfigs-get config var)
(let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(if targ
(or (configf:lookup config targ var)
(configf:lookup config "default" var))
(configf:lookup config "default" var))))
(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
((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
(runconfigs-get rconf testpatt-key)
#f)) ;; We do NOT fall back to "%"
;; (tags-testpatt
;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
;; tags-testpatt)
((and (equal? args-testpatt "%") rtestpatt)
(debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
rtestpatt)
(else args-testpatt))))
(define (common:false-on-exception thunk #!key (message #f))
(handle-exceptions exn
(begin
(if message
(debug:print-info 0 *default-log-port* message))
#f) (thunk) ))
(define (common:file-exists? path-string)
;; this avoids stack dumps in the case where
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(common:false-on-exception (lambda () (file-exists? path-string))
message: (conc "Unable to access path: " path-string)
))
(define (common:directory-exists? path-string)
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(common:false-on-exception (lambda () (directory-exists? path-string))
message: (conc "Unable to access path: " path-string)
))
;; does the directory exist and do we have write access?
;;
;; returns the directory or #f
;;
(define (common:directory-writable? path-string)
(handle-exceptions
exn
#f
(if (and (directory-exists? path-string)
(file-write-access? path-string))
path-string
#f)))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
(if *toppath*
(conc *toppath* "/lt")
#f))))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
(null? (filter string-null? tlist))))
#f)))
(if valid
(if split
tlist
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
(if exit-if-bad (exit 1))
#f)
#f))))
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
(if (getenv "MT_TEST_NAME")
(if (and (getenv "MT_ITEMPATH")
(not (equal? (getenv "MT_ITEMPATH") "")))
(getenv "MT_TEST_NAME")
(conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
#f))
;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
(define (common:get-homehost #!key (trynum 5))
;; called often especially at start up. use mutex to eliminate collisions
|
| ︙ | | | ︙ | |
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
|
(common:get-homehost trynum: (- trynum 1)))
#f))
(else
(let* ((currhost (get-host-name))
(bestadrs (server:get-best-guess-address currhost))
;; first look in config, then look in file .homehost, create it if not found
(homehost (or (configf:lookup *configdat* "server" "homehost" )
(let ((hhf (conc *toppath* "/.homehost")))
(if (file-exists? hhf)
(with-input-from-file hhf read-line)
(if (file-write-access? *toppath*)
(begin
(with-output-to-file hhf
(lambda ()
(print bestadrs)))
(begin
(mutex-unlock! *homehost-mutex*)
(car (common:get-homehost))))
#f)))))
(at-home (or (equal? homehost currhost)
(equal? homehost bestadrs))))
(set! *home-host* (cons homehost at-home))
(mutex-unlock! *homehost-mutex*)
*home-host*))))
;; am I on the homehost?
;;
(define (common:on-homehost?)
(let ((hh (common:get-homehost)))
(if hh
(cdr hh)
#f)))
;;======================================================================
;; M I S C L I S T S
;;======================================================================
;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
|
(common:get-homehost trynum: (- trynum 1)))
#f))
(else
(let* ((currhost (get-host-name))
(bestadrs (server:get-best-guess-address currhost))
;; first look in config, then look in file .homehost, create it if not found
(homehost (or (configf:lookup *configdat* "server" "homehost" )
(handle-exceptions
exn
(if (> trynum 0)
(let ((delay-time (* (- 5 trynum) 5)))
(mutex-unlock! *homehost-mutex*)
(debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file, delaying " delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! delay-time)
(common:get-homehost trynum: (- trynum 1)))
(begin
(mutex-unlock! *homehost-mutex*)
(debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn))
(exit 1)))
(let ((hhf (conc *toppath* "/.homehost")))
(if (file-exists? hhf)
(with-input-from-file hhf read-line)
(if (file-write-access? *toppath*)
(begin
(with-output-to-file hhf
(lambda ()
(print bestadrs)))
(begin
(mutex-unlock! *homehost-mutex*)
(car (common:get-homehost))))
#f))))))
(at-home (or (equal? homehost currhost)
(equal? homehost bestadrs))))
(set! *home-host* (cons homehost at-home))
(mutex-unlock! *homehost-mutex*)
*home-host*))))
;; am I on the homehost?
;;
(define (common:on-homehost?)
(let ((hh (common:get-homehost)))
(if hh
(cdr hh)
#f)))
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
(let ((res #t)) ;; priority by order of evaluation
(if *configdat*
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
(set! res #f)
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
(set! res #t))))
(if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
(if (getenv "MT_USE_CACHE")
(if (equal? (getenv "MT_USE_CACHE") "yes")
(set! res #t)
(if (equal? (getenv "MT_USE_CACHE") "no")
(set! res #f)))) ;; overrides -no-cache switch
res))
;; force use of server?
;;
(define (common:force-server?)
(let* ((force-setting (configf:lookup *configdat* "server" "force"))
(force-type (if force-setting (string->symbol force-setting) #f))
(force-result (case force-type
((#f) #f)
((always) #t)
((test) (if (args:get-arg "-execute") ;; we are in a test
#t
#f))
(else
(debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.")
#t)))) ;; default to requiring server
(if force-result
(begin
(debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".")
#t)
#f)))
;;======================================================================
;; M I S C L I S T S
;;======================================================================
;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
|
| ︙ | | | ︙ | |
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
|
;; S Y S T E M S T U F F
;;======================================================================
;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
(define (common:lazy-modification-time fpath)
(handle-exceptions
exn
0
(file-modification-time fpath)))
;; find timestamp of newest file associated with a sqlite db file
(define (common:lazy-sqlite-db-modification-time fpath)
(let* ((glob-list (handle-exceptions
exn
'("/no/such/file")
(glob (conc fpath "*"))))
'("/no/such/file")
glob-list)))
|
|
|
|
|
|
|
|
|
|
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
|
;; S Y S T E M S T U F F
;;======================================================================
;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
(define (common:lazy-modification-time fpath)
(handle-exceptions
exn
0
(file-modification-time fpath)))
;; find timestamp of newest file associated with a sqlite db file
(define (common:lazy-sqlite-db-modification-time fpath)
(let* ((glob-list (handle-exceptions
exn
`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
(glob (conc fpath "*"))))
(file-list (if (eq? 0 (length glob-list))
'("/no/such/file")
glob-list)))
(apply max
(map
common:lazy-modification-time
file-list))))
;; return a nice clean pathname made absolute
(define (common:nice-path dir)
|
| ︙ | | | ︙ | |
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
|
(if (and best (> bestsize minsize))
best
#f))) ;; #f means no disk candidate found
;;======================================================================
;; E N V I R O N M E N T V A R S
;;======================================================================
(with-output-to-file (conc fname ".csh")
(print (if (member key ignorevars)
"# export "
"export ")
key "=" delim (mungeval val) delim)))
envvars)))))
;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
|
>
>
>
>
>
>
|
>
>
|
|
>
|
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
|
(if (and best (> bestsize minsize))
best
#f))) ;; #f means no disk candidate found
;;======================================================================
;; E N V I R O N M E N T V A R S
;;======================================================================
(define (bb-check-path #!key (msg "check-path: "))
(let ((path (or (get-environment-variable "PATH") "none")))
(debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
(if (string-match "^.*/isoenv-core/.*" path)
(debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
(debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES")))
;;(bb-check-path msg: "save-environment-as-files entry")
(let ((envvars (get-environment-variables))
(whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))
(mungeval (lambda (val)
(cond
((eq? val #t) "") ;; convert #t to empty string
((eq? val #f) #f) ;; convert #f to itself (still thinking about this one
(else val)))))
(with-output-to-file (conc fname ".csh")
(lambda ()
(for-each (lambda (keyval)
(let* ((key (car keyval))
(val (cdr keyval))
(delim (if (string-search whitesp val)
"\""
"")))
(print (if (member key ignorevars)
"# setenv "
"setenv ")
key " " delim (mungeval val) delim)))
envvars)))
(with-output-to-file (conc fname ".sh")
(lambda ()
(for-each (lambda (keyval)
(let* ((key (car keyval))
(val (cdr keyval))
(delim (if (string-search whitesp val)
"\""
"")))
(print (if (or (member key ignorevars)
(string-search ":" key)) ;; internal only values to be skipped.
"# export "
"export ")
key "=" delim (mungeval val) delim)))
envvars)))))
;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
|
| ︙ | | | ︙ | |
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
|
"%m"))
((1 2 3) 1)
((4 5 6) 2)
((7 8 9) 3)
((10 11 12) 4)
(else #f)))
;; given span of seconds tstart to tend
;; find start time to mark and mark delta
;;
(define (common:find-start-mark-and-mark-delta tstart tend)
(let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
(result #f)
(min 60)
|
>
>
>
>
>
|
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
|
"%m"))
((1 2 3) 1)
((4 5 6) 2)
((7 8 9) 3)
((10 11 12) 4)
(else #f)))
;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
;;
(define (common:date-time->seconds datetime)
(local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
;; given span of seconds tstart to tend
;; find start time to mark and mark delta
;;
(define (common:find-start-mark-and-mark-delta tstart tend)
(let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
(result #f)
(min 60)
|
| ︙ | | | ︙ | |
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
|
(list yr mo wk day hr min 1)
'( y mo w d h m s))))
(list 8 6 5 2 1)))
'(5 10 15 20 30 40 50 500))
(if values
(apply values result)
(values 0 day 1 0 'd))))
|
|
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
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
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
|
(list yr mo wk day hr min 1)
'( y mo w d h m s))))
(list 8 6 5 2 1)))
'(5 10 15 20 30 40 50 500))
(if values
(apply values result)
(values 0 day 1 0 'd))))
;; given x y lim return the cron expansion
;;
(define (common:expand-cron-slash x y lim)
(let loop ((curr x)
(res `()))
(if (< curr lim)
(loop (+ curr y) (cons curr res))
(reverse res))))
;; expand a complex cron string to a list of cron strings
;;
;; x/y => x, x+y, x+2y, x+3y while x+Ny<max_for_field
;; a,b,c => a, b ,c
;;
;; NOTE: with flatten a lot of the crud below can be factored down.
;;
(define (common:cron-expand cron-str)
(if (list? cron-str)
(flatten
(fold (lambda (x res)
(if (list? x)
(let ((newres (map common:cron-expand x)))
(append x newres))
(cons x res)))
'()
cron-str)) ;; (map common:cron-expand cron-str))
(let ((cron-items (string-split cron-str))
(slash-rx (regexp "(\\d+)/(\\d+)"))
(comma-rx (regexp ".*,.*"))
(max-vals '((min . 60)
(hour . 24)
(dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
(month . 12)
(dayofweek . 7))))
(if (< (length cron-items) 5) ;; bad spec
cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it
(let loop ((hed (car cron-items))
(tal (cdr cron-items))
(type 'min)
(type-tal '(hour dayofmonth month dayofweek))
(res '()))
(regex-case
hed
(slash-rx ( _ base incr ) (let* ((basen (string->number base))
(incrn (string->number incr))
(expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
(new-list-crons (fold (lambda (x myres)
(cons (conc (if (null? res)
""
(conc (string-intersperse res " ") " "))
x " " (string-intersperse tal " "))
myres))
'() expanded-vals)))
;; (print "new-list-crons: " new-list-crons)
;; (fold (lambda (x res)
;; (if (list? x)
;; (let ((newres (map common:cron-expand x)))
;; (append x newres))
;; (cons x res)))
;; '()
(flatten (map common:cron-expand new-list-crons))))
;; (map common:cron-expand (map common:cron-expand new-list-crons))))
(else (if (null? tal)
cron-str
(loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
;; given a cron string and the last time event was processed return #t to run or #f to not run
;;
;; min hour dayofmonth month dayofweek
;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7
;;
;; #t => yes, run the job
;; #f => no, do not run the job
;;
(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
(let* ((cron-items (map string->number (string-split cron-str)))
(now-seconds (or now-seconds-in (current-seconds)))
(now-time (seconds->local-time now-seconds))
(last-done-time (seconds->local-time last-done))
(all-times (make-hash-table)))
;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
(if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
#f
(match-let ((( cmin chour cdayofmonth cmonth cdayofweek)
cron-items)
;; 0 1 2 3 4 5 6
((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
(vector->list now-time))
((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
(vector->list last-done-time)))
;; create all possible time slots
;; remove invalid slots due to (for example) day of week
;; get the start and end entries for the ref-seconds (current) time
;; if last-done > ref-seconds => this is an ERROR!
;; does the last-done time fall in the legit region?
;; yes => #f do not run again this command
;; no => #t ok to run the command
(for-each ;; month
(lambda (month)
(for-each ;; dayofmonth
(lambda (dom)
(for-each
(lambda (hr) ;; hour
(for-each
(lambda (minute) ;; minute
(let ((copy-now (apply vector (vector->list now-time))))
(vector-set! copy-now 0 0) ;; force seconds to zero
(vector-set! copy-now 1 minute)
(vector-set! copy-now 2 hr)
(vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced
(vector-set! copy-now 4 month)
(let* ((copy-now-secs (local-time->seconds copy-now))
(new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector
(if (or (not cdayofweek)
(equal? (vector-ref new-copy 6)
cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
(if (or (not cdayofmonth)
(equal? (vector-ref new-copy 3)
(+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
(hash-table-set! all-times copy-now-secs new-copy))))))
(if cmin
`(,cmin) ;; if given cmin, have to use it
(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
(if chour
`(,chour)
(list (- nhour 1) nhour (+ nhour 1))))) ;; hour
(if cdayofmonth
`(,cdayofmonth)
(list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
(if cmonth
`(,cmonth)
(list (- nmonth 1) nmonth (+ nmonth 1))))
(let ((before #f)
(is-in #f))
(for-each
(lambda (moment)
(if (and before
(<= before now-seconds)
(>= moment now-seconds))
(begin
;; (print)
;; (print "Before: " (time->string (seconds->local-time before)))
;; (print "Now: " (time->string (seconds->local-time now-seconds)))
;; (print "After: " (time->string (seconds->local-time moment)))
;; (print "Last: " (time->string (seconds->local-time last-done)))
(if (< last-done before)
(set! is-in before))
))
(set! before moment))
(sort (hash-table-keys all-times) <))
is-in)))))
(define (common:extended-cron cron-str now-seconds-in last-done)
(let ((expanded-cron (common:cron-expand cron-str)))
(if (string? expanded-cron)
(common:cron-event expanded-cron now-seconds-in last-done)
(let loop ((hed (car expanded-cron))
(tal (cdr expanded-cron)))
(if (common:cron-event hed now-seconds-in last-done)
#t
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
;;======================================================================
;; C O L O R S
;;======================================================================
(define (common:name->iup-color name)
(case (string->symbol (string-downcase name))
|
| ︙ | | | ︙ | |
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
|
(string-intersperse
(map (lambda (x)
(number->string x 16))
(map string->number
(string-split instr)))
"/"))
(define (common:get-color-from-status status)
(cond
((equal? status "PASS") "green")
((equal? status "FAIL") "red")
((equal? status "WARN") "orange")
((equal? status "KILLED") "orange")
((equal? status "KILLREQ") "purple")
((equal? status "RUNNING") "blue")
((equal? status "ABORT") "brown")
(else "black")))
;;======================================================================
;; N A N O M S G C L I E N T
;;======================================================================
(define (server:get-best-guess-address hostname)
(let ((res #f))
(for-each
(lambda (adr)
(if (not (eq? (u8vector-ref adr 0) 127))
(set! res adr)))
;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
(vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
(define (common:send-dboard-main-changed)
(let* ((dashboard-ips (mddb:get-dashboards)))
(for-each
(lambda (ipadr)
(let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
(msg (conc "main " *toppath*))
(res (common:nm-send-receive-timeout soc msg)))
(if (not res) ;; couldn't reach that dashboard - remove it from db
(print "ERROR: couldn't reach dashboard " ipadr))
res))
dashboard-ips)))
;;======================================================================
;; D A S H B O A R D D B
;;======================================================================
(define (mddb:open-db)
(let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
(set-busy-handler! db (busy-timeout 10000))
(for-each
(lambda (qry)
(exec (sql db qry)))
(list
"CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
"CREATE TABLE IF NOT EXISTS dashboards (
id INTEGER PRIMARY KEY,
pid INTEGER,
username TEXT,
hostname TEXT,
ipaddr TEXT,
portnum INTEGER,
start_time TIMESTAMP DEFAULT (strftime('%s','now')),
CONSTRAINT hostport UNIQUE (hostname,portnum)
);"
))
db))
;; register a dashboard
;;
(define (mddb:register-dashboard port)
(let* ((pid (current-process-id))
(hostname (get-host-name))
(ipaddr (server:get-best-guess-address hostname))
(username (current-user-name)) ;; (car userinfo)))
(db (mddb:open-db)))
(print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
(exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
pid username hostname ipaddr port)
(close-database db)))
;; unregister a monitor
;;
(define (mddb:unregister-dashboard host port)
(let* ((db (mddb:open-db)))
(print "Register unregister monitor, host:port=" host ":" port)
(exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
(close-database db)))
;; get registered dashboards
;;
(define (mddb:get-dashboards)
(let ((db (mddb:open-db)))
(query fetch-column
(sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;======================================================================
;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
;;======================================================================
;;
;; [hosts]
;; arm cubie01 cubie02
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
|
(string-intersperse
(map (lambda (x)
(number->string x 16))
(map string->number
(string-split instr)))
"/"))
(define (common:faux-lock keyname)
(if (rmt:get-var keyname)
#f
(begin
(rmt:set-var keyname (conc (current-process-id)))
(equal? (conc (current-process-id)) (conc (rmt:get-var keyname))))))
(define (common:faux-unlock keyname #!key (force #f))
(if (or force (equal? (conc (current-process-id)) (conc (rmt:get-var keyname))))
(begin
(if (rmt:get-var keyname) (rmt:del-var keyname))
#t)
#f))
(define (common:in-running-test?)
(and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO")))
(define (common:get-color-from-status status)
(cond
((equal? status "PASS") "green")
((equal? status "FAIL") "red")
((equal? status "WARN") "orange")
((equal? status "KILLED") "orange")
((equal? status "KILLREQ") "purple")
((equal? status "RUNNING") "blue")
((equal? status "ABORT") "brown")
(else "black")))
;; ;;======================================================================
;; ;; N A N O M S G C L I E N T
;; ;;======================================================================
;;
;;
;;
;; (define (common:send-dboard-main-changed)
;; (let* ((dashboard-ips (mddb:get-dashboards)))
;; (for-each
;; (lambda (ipadr)
;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
;; (msg (conc "main " *toppath*))
;; (res (common:nm-send-receive-timeout soc msg)))
;; (if (not res) ;; couldn't reach that dashboard - remove it from db
;; (print "ERROR: couldn't reach dashboard " ipadr))
;; res))
;; dashboard-ips)))
;;
;;
;; ;;======================================================================
;; ;; D A S H B O A R D D B
;; ;;======================================================================
;;
;; (define (mddb:open-db)
;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
;; (set-busy-handler! db (busy-timeout 10000))
;; (for-each
;; (lambda (qry)
;; (exec (sql db qry)))
;; (list
;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
;; "CREATE TABLE IF NOT EXISTS dashboards (
;; id INTEGER PRIMARY KEY,
;; pid INTEGER,
;; username TEXT,
;; hostname TEXT,
;; ipaddr TEXT,
;; portnum INTEGER,
;; start_time TIMESTAMP DEFAULT (strftime('%s','now')),
;; CONSTRAINT hostport UNIQUE (hostname,portnum)
;; );"
;; ))
;; db))
;;
;; ;; register a dashboard
;; ;;
;; (define (mddb:register-dashboard port)
;; (let* ((pid (current-process-id))
;; (hostname (get-host-name))
;; (ipaddr (server:get-best-guess-address hostname))
;; (username (current-user-name)) ;; (car userinfo)))
;; (db (mddb:open-db)))
;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
;; pid username hostname ipaddr port)
;; (close-database db)))
;;
;; ;; unregister a monitor
;; ;;
;; (define (mddb:unregister-dashboard host port)
;; (let* ((db (mddb:open-db)))
;; (print "Register unregister monitor, host:port=" host ":" port)
;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
;; (close-database db)))
;;
;; ;; get registered dashboards
;; ;;
;; (define (mddb:get-dashboards)
;; (let ((db (mddb:open-db)))
;; (query fetch-column
;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;======================================================================
;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
;;======================================================================
;;
;; [hosts]
;; arm cubie01 cubie02
|
| ︙ | | | ︙ | |