| ︙ | | | ︙ | |
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
;; PURPOSE.
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
(use regex regex-case base64 sqlite3 srfi-18)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
;;======================================================================
;; ezsteps
|
|
>
>
>
|
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
|
;; PURPOSE.
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
;; (declare (uses sdb))
(declare (uses tdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
;;======================================================================
;; ezsteps
|
| ︙ | | | ︙ | |
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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
(or (eq? exitcode 0)
(and logpro (eq? exitcode 2))))
;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
(let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
(if enccmd
(read (open-input-string (base64:base64-decode enccmd)))
'())))
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd)))))
(setenv "MT_CMDINFO" encoded-cmd)
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
(let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area
(top-path (assoc/default 'toppath cmdinfo))
(work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(ezsteps (assoc/default 'ezsteps cmdinfo))
;; (runremote (assoc/default 'runremote cmdinfo))
(transport (assoc/default 'transport cmdinfo))
(serverinf (assoc/default 'serverinf cmdinfo))
(port (assoc/default 'port cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(target (assoc/default 'target 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))
(runtlim (assoc/default 'runtlim cmdinfo))
(mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
(keys #f)
(keyvals #f)
(fullrunscript (if (not runscript)
#f
(if (substring-index "/" runscript)
runscript ;; use unadultered if contains slashes
(let ((fulln (conc testpath "/" runscript)))
(if (and (file-exists? fulln)
(file-execute-access? fulln))
fulln
runscript))))) ;; assume it is on the path
(rollup-status 0))
(change-directory top-path)
(debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
;; one of these is defunct/redundant ...
(if (not (launch:setup-for-run force: #t))
(begin
(debug:print 0 "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
(change-directory *toppath*)
(let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; Now have runconfigs data loaded, set environment vars
(for-each (lambda (section)
(for-each (lambda (varval)
(let ((var (car varval))
(val (cadr varval)))
(if (and (string? var)(string? val))
(begin
(setenv var (config:eval-string-in-environment val))) ;; val)
(debug:print 0 "ERROR: bad variable spec, " var "=" val))))
(configf:get-section rconfig section)))
(list "default" target)))
(change-directory work-area)
;; Setup the *runremote* global var
(if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
;; (set! *runremote* runremote)
;; (set! *transport-type* (string->symbol transport))
(set! keys (cdb:remote-run db:get-keys #f))
|
|
|
|
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
<
<
<
<
<
|
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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
(or (eq? exitcode 0)
(and logpro (eq? exitcode 2))))
;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
(let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
(if enccmd
(common:read-encoded-string enccmd)
'())))
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd)))
(setenv "MT_CMDINFO" encoded-cmd)
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
(let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area
(top-path (assoc/default 'toppath cmdinfo))
(work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(ezsteps (assoc/default 'ezsteps cmdinfo))
;; (runremote (assoc/default 'runremote cmdinfo))
(transport (assoc/default 'transport cmdinfo))
;; (serverinf (assoc/default 'serverinf cmdinfo))
(port (assoc/default 'port cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(target (assoc/default 'target 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))
(runtlim (assoc/default 'runtlim cmdinfo))
(item-path (item-list->path itemdat))
(mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
(keys #f)
(keyvals #f)
(fullrunscript (if (not runscript)
#f
(if (substring-index "/" runscript)
runscript ;; use unadultered if contains slashes
(let ((fulln (conc testpath "/" runscript)))
(if (and (file-exists? fulln)
(file-execute-access? fulln))
fulln
runscript))))) ;; assume it is on the path
(rollup-status 0))
(change-directory top-path)
;; (set-signal-handler! signal/int (lambda ()
;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
;;
(let ((test-info (rmt:get-testinfo-state-status run-id test-id)))
(if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(begin
(debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed")
(exit))))
(debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
(set! keys (rmt:get-keys))
;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
;; one of these is defunct/redundant ...
(if (not (launch:setup-for-run force: #t))
(begin
(debug:print 0 "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
(change-directory *toppath*)
;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This
;; seems non-ideal but could well break stuff
;; BUG? BUG? BUG?
(let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; Now have runconfigs data loaded, set environment vars
(for-each (lambda (section)
(for-each (lambda (varval)
(let ((var (car varval))
(val (cadr varval)))
(if (and (string? var)(string? val))
(begin
(setenv var (config:eval-string-in-environment val))) ;; val)
(debug:print 0 "ERROR: bad variable spec, " var "=" val))))
(configf:get-section rconfig section)))
(list "default" target)))
(change-directory work-area)
(set! keyvals (keys:target->keyval keys target))
;; apply pre-overrides before other variables. The pre-override vars must not
;; clobbers things from the official sources such as megatest.config and runconfigs.config
(if (string? set-vars)
(let ((varpairs (string-split set-vars ",")))
(debug:print 4 "varpairs: " varpairs)
(map (lambda (varpair)
|
| ︙ | | | ︙ | |
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
(begin
(debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting")
(exit)))))
(list
(list "MT_TEST_RUN_DIR" work-area)
(list "MT_TEST_NAME" test-name)
(list "MT_ITEM_INFO" (conc itemdat))
(list "MT_RUNNAME" runname)
(list "MT_MEGATEST" megatest)
(list "MT_TARGET" target)
(list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree"))))
(if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
(runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
;; open-run-close not needed for test-set-meta-info
(tests:set-full-meta-info #f test-id run-id 0 work-area 10)
;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
(tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a")
|
>
|
>
>
>
>
<
<
|
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
(begin
(debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting")
(exit)))))
(list
(list "MT_TEST_RUN_DIR" work-area)
(list "MT_TEST_NAME" test-name)
(list "MT_ITEM_INFO" (conc itemdat))
(list "MT_ITEMPATH" item-path)
(list "MT_RUNNAME" runname)
(list "MT_MEGATEST" megatest)
(list "MT_TARGET" target)
(list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree"))
(list "MT_TESTSUITENAME" (common:get-testsuite-name))))
(if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
(runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
;; open-run-close not needed for test-set-meta-info
;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
;; (tests:set-full-meta-info test-id run-id 0 work-area)
(tests:set-full-meta-info #f test-id run-id 0 work-area 10)
(thread-sleep! 0.3) ;; NFS slowness has caused grief here
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript (not (file-execute-access? fullrunscript)))
(system (conc "chmod ug+x " fullrunscript))))
;; We are about to actually kick off the test
|
| ︙ | | | ︙ | |
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
;; (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! test-id "RUNNING" "n/a")
(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)))
(let loop ((i 0))
(let-values
(((pid-val exit-status exit-code) (process-wait pid #t)))
(mutex-lock! m)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
|
|
>
>
|
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
;; (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:roll-up-pass-fail-counts run-id test-name item-path "RUNNING")
(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)
(let loop ((i 0))
(let-values
(((pid-val exit-status exit-code) (process-wait pid #t)))
(mutex-lock! m)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
|
| ︙ | | | ︙ | |
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
|
;; (if (and prevstep (file-exists? prev-env))
;; (set! script (conc script "source " prev-env))))
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
;; DO NOT remote
(db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: work-area)
;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
(db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area))
(cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
(overall-status (cond
((eq? rollup-status 2) 'warn)
|
<
|
>
<
|
|
|
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
|
;; (if (and prevstep (file-exists? prev-env))
;; (set! script (conc script "source " prev-env))))
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
(rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
;; now launch
(let ((pid (process-run script)))
(rmt:test-set-top-process-pid run-id test-id pid)
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
(mutex-unlock! m)
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
(rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
(if logpro-used
(rmt:test-set-log! run-id test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
(overall-status (cond
((eq? rollup-status 2) 'warn)
|
| ︙ | | | ︙ | |
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
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
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
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
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
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
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
|
(debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status
" next-status: " next-status " rollup-status: " rollup-status)
(case next-status
((warn)
(set! rollup-status 2)
;; NB// test-set-status! does rdb calls under the hood
(tests:test-set-status! test-id next-state "WARN"
(if (eq? this-step-status 'warn) "Logpro warning found" #f)
#f))
((pass)
(tests:test-set-status! test-id next-state "PASS" #f #f))
(else ;; 'fail
(set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
(tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
))))
(if (and (steprun-good? logpro-used (vector-ref exit-info 2))
(not (null? tal)))
(loop (car tal) (cdr tal) stepname)))
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
(monitorjob (lambda ()
(let* ((start-seconds (current-seconds))
(calc-minutes (lambda ()
(inexact->exact
(round
(-
(current-seconds)
start-seconds)))))
(kill-tries 0))
(tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
(let loop ((minutes (calc-minutes)))
(begin
(set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat))
(and runtlim (let* ((run-seconds (- (current-seconds) start-seconds))
(time-exceeded (> run-seconds runtlim)))
(if time-exceeded
(begin
(debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
#t)
#f)))))
;; open-run-close not needed for test-set-meta-info
(tests:set-partial-meta-info #f test-id run-id minutes work-area 10)
(let* ((pid (vector-ref exit-info 0)))
(if (number? pid)
(handle-exceptions
exn
(debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.")
;;(process-signal pid signal/kill))
(begin
(debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
(let ((processes (cmd-run->list (conc "pgrep -l -P " pid))))
(for-each
(lambda (p)
(let* ((parts (string-split p))
(p-id (if (> (length parts) 0)
(string->number (car parts))
#f)))
(if p-id
(begin
(debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id)
;; (process-signal pid signal/kill))))) ;;
(system (conc "kill -9 " p-id))))))
(car processes)))
(system (conc "kill -9 -" pid))
(tests:test-set-status! test-id "KILLED" "KILLED" (args:get-arg "-m") #f)))
(begin
(debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
(tests:test-set-status! test-id "KILLED" "KILLED" (args:get-arg "-m") #f)
(sqlite3:finalize! tdb)
(exit 1) ;; IS THIS NECESSARY OR WISE???
)))
(set! kill-tries (+ 1 kill-tries))
(mutex-unlock! m)))
;; (sqlite3:finalize! db)
(if keep-going
(begin
(thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
(if keep-going
(loop (calc-minutes)))))))
(tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional
(th1 (make-thread monitorjob "monitor job"))
(th2 (make-thread runit "run job")))
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(set! keep-going #f)
(thread-join! th1)
;; (thread-sleep! 1)
;; (thread-terminate! th1) ;; Not sure if this is a good idea
;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
(testinfo (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path)))
;; Am I completed?
(if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
;; "COMPLETED"
;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
)
(new-status (cond
((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run
((eq? rollup-status 0)
;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO)
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
((eq? rollup-status 1) "FAIL")
((eq? rollup-status 2)
;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
(else "FAIL")))) ;; (db:test-get-status testinfo)))
(debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status)
(tests:test-set-status! test-id
new-state
new-status
(args:get-arg "-m") #f)
;; need to update the top test record if PASS or FAIL and this is a subtest
;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status!
;; (if (not (equal? item-path ""))
;; (begin
;; (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority
;; (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))
(tests:summarize-items #f run-id test-id test-name #f))) ;; don't force - just update if no
(mutex-unlock! m)
(debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area "
work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
(if (not (vector-ref exit-info 1))
(exit 4)))))))
;; set up the very basics needed for doing anything here.
(define (launch:setup-for-run #!key (force #f))
;; would set values for KEYS in the environment here for better support of env-override but
;; have chicken/egg scenario. need to read megatest.config then read it again. Going to
;; pass on that idea for now
;; special case
(if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call
(begin
(set! *configinfo* (find-and-read-config
(if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
environ-patt: "env-override"
given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
pathenvvar: "MT_RUN_AREA_HOME"))
(set! *configdat* (if (car *configinfo*)(car *configinfo*) #f))
(set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f))
(if *toppath*
(setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated
(debug:print 0 "ERROR: failed to find the top path to your Megatest area."))))
*toppath*)
(define (get-best-disk confdat)
(let* ((disks (hash-table-ref/default confdat "disks" #f))
(best #f)
(bestsize 0))
(if disks
(for-each
(lambda (disk-num)
(let* ((dirpath (cadr (assoc disk-num disks)))
(freespc (if (and (directory? dirpath)
(file-write-access? dirpath))
(get-df dirpath)
(begin
(debug:print 0 "WARNING: path " dirpath " in [disks] section not valid or writable")
0))))
(if (> freespc bestsize)
(begin
(set! best dirpath)
(set! bestsize freespc)))))
(map car disks)))
(if best
best
(begin
(debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section")
(exit 1)))))
;; Desired directory structure:
;;
;; <linkdir> - <target> - <testname> -.
;; |
;; v
;; <rundir> - <target> - <testname> -|- <itempath(s)>
;;
;; dir stored in test is:
;;
;; <linkdir> - <target> - <testname> [ - <itempath> ]
;;
;; All log file links should be stored relative to the top of link path
;;
;; <target> - <testname> [ - <itempath> ]
;;
(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat)
(let* ((item-path (item-list->path itemdat))
(runname (db:get-value-by-header (db:get-row run-info)
(db:get-header run-info)
"runname"))
;; convert back to db: from rdb: - this is always run at server end
(target (string-intersperse (map cadr keyvals) "/"))
(not-iterated (equal? "" item-path))
;; all tests are found at <rundir>/test-base or <linkdir>/test-base
(testtop-base (conc target "/" runname "/" testname))
(test-base (conc testtop-base (if not-iterated "" "/") item-path))
;; nb// if itempath is not "" then it is prefixed with "/"
(toptest-path (conc disk-path "/" testtop-base))
(test-path (conc disk-path "/" test-base))
;; ensure this exists first as links to subtests must be created there
(linktree (let ((rd (config-lookup *configdat* "setup" "linktree")))
(if rd rd (conc *toppath* "/runs"))))
(lnkbase (conc linktree "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))
;; Update the rundir path in the test record for all
(cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf)
(debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
(if (not (file-exists? linktree))
(begin
(debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
(create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
;; create the directory for the tests dir links, this is needed no matter what...
(if (and (not (directory-exists? lnkbase))
(not (file-exists? lnkbase)))
(create-directory lnkbase #t))
;; update the toptest record with its location rundir, cache the path
;; This wass highly inefficient, one db write for every subtest, potentially
;; thousands of unnecessary updates, cache the fact it was set and don't set it
;; again.
;; NB - This is not working right - some top tests are not getting the path set!!!
(if (not (hash-table-ref/default *toptest-paths* testname #f))
(let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path))
(curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
(hash-table-set! *toptest-paths* testname curr-test-path)
;; NB// Was this for the test or for the parent in an iterated test?
(cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
(create-directory toptest-path #t)
(hash-table-set! *toptest-paths* testname toptest-path)))))
|
|
|
|
>
>
|
<
|
|
>
>
|
>
>
>
|
|
<
<
|
>
>
|
<
<
<
<
<
<
<
|
|
<
|
<
>
|
>
|
|
|
|
<
<
<
|
>
|
|
>
<
<
<
|
|
>
<
<
<
<
|
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
|
<
>
|
>
>
|
|
>
|
|
|
|
|
|
>
|
>
|
>
>
>
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
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
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
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
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
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
563
564
565
566
567
568
569
570
571
572
573
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
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
|
(debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status
" next-status: " next-status " rollup-status: " rollup-status)
(case next-status
((warn)
(set! rollup-status 2)
;; NB// test-set-status! does rdb calls under the hood
(tests:test-set-status! run-id test-id next-state "WARN"
(if (eq? this-step-status 'warn) "Logpro warning found" #f)
#f))
((pass)
(tests:test-set-status! run-id test-id next-state "PASS" #f #f))
(else ;; 'fail
(set! rollup-status 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)
))))
(if (and (steprun-good? logpro-used (vector-ref exit-info 2))
(not (null? tal)))
(loop (car tal) (cdr tal) stepname)))
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
(monitorjob (lambda ()
(let* ((start-seconds (current-seconds))
(calc-minutes (lambda ()
(inexact->exact
(round
(-
(current-seconds)
start-seconds)))))
(kill-tries 0))
;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
(tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
(let loop ((minutes (calc-minutes)))
(begin
(set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat))
(and runtlim (let* ((run-seconds (- (current-seconds) start-seconds))
(time-exceeded (> run-seconds runtlim)))
(if time-exceeded
(begin
(debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
#t)
#f)))))
(tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)
(if kill-job?
(begin
(mutex-lock! m)
;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
;; section and the runit section? Or add a loop that tries three times with a 1/4 second
;; between tries?
(let* ((pid1 (vector-ref exit-info 0))
(pid2 (rmt:test-get-top-process-pid run-id test-id))
(pids (delete-duplicates (filter number? (list pid1 pid2)))))
(if (not (null? pids))
(begin
(for-each
(lambda (pid)
(handle-exceptions
exn
(begin
(debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.")
(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
(debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")")
(if (process:alive? pid)
(begin
(process-signal pid signal/int)
(thread-sleep! 5)
(if (process:process-alive? pid)
(process-signal pid signal/kill))))))
pids)
(tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f))
(begin
(debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2)
(tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f)
)))
(mutex-unlock! m)
;; no point in sticking around. Exit now.
(exit)))
(if keep-going
(begin
(thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
(if keep-going
(loop (calc-minutes)))))))
(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
(th1 (make-thread monitorjob "monitor job"))
(th2 (make-thread runit "run job")))
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...")
(set! keep-going #f)
(thread-join! th1)
(thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.
(mutex-lock! m)
(let* ((item-path (item-list->path itemdat))
;; only state and status needed - use lazy routine
(testinfo (rmt:get-testinfo-state-status run-id test-id)))
;; Am I completed?
(if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
;; "COMPLETED"
;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
)
(new-status (cond
((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run
((eq? rollup-status 0)
;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO)
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
((eq? rollup-status 1) "FAIL")
((eq? rollup-status 2)
;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
(else "FAIL")))) ;; (db:test-get-status testinfo)))
(debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status)
(tests:test-set-status! run-id
test-id
new-state
new-status
(args:get-arg "-m") #f)
;; need to update the top test record if PASS or FAIL and this is a subtest
;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status!
))
;; for automated creation of the rollup html file this is a good place...
(if (not (equal? item-path ""))
(tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no
(mutex-unlock! m)
(debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area "
work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
(if (not (vector-ref exit-info 1))
(exit 4)))))))
;; set up the very basics needed for doing anything here.
(define (launch:setup-for-run #!key (force #f))
;; would set values for KEYS in the environment here for better support of env-override but
;; have chicken/egg scenario. need to read megatest.config then read it again. Going to
;; pass on that idea for now
;; special case
(if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call
(begin
(set! *configinfo* (or (if (get-environment-variable "MT_MDINFO") ;; we are inside a test - do not reprocess configs
(let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
(get-environment-variable "MT_TARGET") "/"
(get-environment-variable "MT_RUNNAME") "/"
".megatest.cfg")))
(if (file-exists? alistconfig)
(list (configf:read-alist alistconfig)
(get-environment-variable "MT_RUN_AREA_HOME"))
#f))
#f) ;; no config cached - give up
(find-and-read-config
(if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
environ-patt: "env-override"
given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
pathenvvar: "MT_RUN_AREA_HOME")))
(set! *configdat* (if (car *configinfo*)(car *configinfo*) #f))
(set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f))
(let* ((tmptransport (configf:lookup *configdat* "server" "transport"))
(transport (if tmptransport (string->symbol tmptransport) 'http)))
(if (member transport '(http rpc nmsg))
(set! *transport-type* transport)
(begin
(debug:print 0 "ERROR: Unrecognised transport " transport)
(exit))))
(let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical
(if linktree
(if (not (file-exists? linktree))
(begin
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
(exit 1))
(create-directory linktree #t))))
(begin
(debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
(exit 1)))
(if linktree
(let ((dbdir (conc linktree "/.db")))
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
(if (not (directory-exists? dbdir))(create-directory dbdir)))
(setenv "MT_LINKTREE" linktree))
(begin
(debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
(exit 1)))
(if (and *toppath*
(directory-exists? *toppath*))
(setenv "MT_RUN_AREA_HOME" *toppath*)
(begin
(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
(exit 1)))
)))
*toppath*)
(define (launch:cache-config)
;; if we have a linktree and -runtests and -target and the directory exists dump the config
;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
(if (and *configdat*
(args:get-arg "-runtests"))
(let* ((linktree (get-environment-variable "MT_LINKTREE"))
(target (common:args-get-target))
(runname (or (args:get-arg "-runname")
(args:get-arg ":runname")))
(fulldir (conc linktree "/"
target "/"
runname)))
(debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir)
(if (file-exists? linktree) ;; can't proceed without linktree
(begin
(if (not (file-exists? fulldir))
(create-directory fulldir #t)) ;; need to protect with exception handler
(if (and target
runname
(file-exists? fulldir))
(let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
(targfile (conc fulldir "/.megatest.cfg")))
(debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
(configf:write-alist *configdat* tmpfile)
(system (conc "ln -sf " tmpfile " " targfile))
)))))))
(define (get-best-disk confdat)
(let* ((disks (hash-table-ref/default confdat "disks" #f))
(best #f)
(bestsize 0))
(if disks
(for-each
(lambda (disk-num)
(let* ((dirpath (cadr (assoc disk-num disks)))
(freespc (cond
((not (directory? dirpath))
(if (common:low-noise-print 50 "disks not a dir " disk-num)
(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it."))
-1)
((not (file-write-access? dirpath))
(if (common:low-noise-print 50 "disks not writeable " disk-num)
(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it."))
-1)
((not (eq? (string-ref dirpath 0) #\/))
(if (common:low-noise-print 50 "disks not a proper path " disk-num)
(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it."))
-1)
(else
(get-df dirpath)))))
(if (> freespc bestsize)
(begin
(set! best dirpath)
(set! bestsize freespc)))))
(map car disks)))
(if (and best (> bestsize 0))
best
(begin
(if (common:low-noise-print 20 "no valid disks")
(debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!"))
(exit 1)))))
;; Desired directory structure:
;;
;; <linkdir> - <target> - <testname> -.
;; |
;; v
;; <rundir> - <target> - <testname> -|- <itempath(s)>
;;
;; dir stored in test is:
;;
;; <linkdir> - <target> - <testname> [ - <itempath> ]
;;
;; All log file links should be stored relative to the top of link path
;;
;; <target> - <testname> [ - <itempath> ]
;;
(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2))
(let* ((item-path (item-list->path itemdat))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info)
"runname"))
;; convert back to db: from rdb: - this is always run at server end
(target (string-intersperse (map cadr keyvals) "/"))
(not-iterated (equal? "" item-path))
;; all tests are found at <rundir>/test-base or <linkdir>/test-base
(testtop-base (conc target "/" runname "/" testname))
(test-base (conc testtop-base (if not-iterated "" "/") item-path))
;; nb// if itempath is not "" then it is prefixed with "/"
(toptest-path (conc disk-path "/" testtop-base))
(test-path (conc disk-path "/" test-base))
;; ensure this exists first as links to subtests must be created there
(linktree (let ((rd (config-lookup *configdat* "setup" "linktree")))
(if rd rd (conc *toppath* "/runs"))))
(lnkbase (conc linktree "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))
(lnktarget (conc lnkpath "/" item-path)))
;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
;; rundir shortdir
(rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path)
(debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
(if (not (file-exists? linktree))
(begin
(debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
(create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
;; create the directory for the tests dir links, this is needed no matter what...
(if (and (not (directory-exists? lnkbase))
(not (file-exists? lnkbase)))
(handle-exceptions
exn
(begin
(debug:print "ERROR: Problem creating linktree base at " lnkbase)
(print-error-message exn (current-error-port)))
(create-directory lnkbase #t)))
;; update the toptest record with its location rundir, cache the path
;; This wass highly inefficient, one db write for every subtest, potentially
;; thousands of unnecessary updates, cache the fact it was set and don't set it
;; again.
;; Now create the link from the test path to the link tree, however
;; if the test is iterated it is necessary to create the parent path
;; to the iteration. use pathname-directory to trim the path by one
;; level
(if (not not-iterated) ;; i.e. iterated
(let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path))))
(debug:print-info 2 "Creating iterated parent " iterated-parent)
|
| ︙ | | | ︙ | |
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
|
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
(create-symbolic-link toptest-path lnkpath)))
;; The toptest path has been created, the link to the test in the linktree has
;; been created. Now, if this is an iterated test the real test dir must be created
(if (not not-iterated) ;; this is an iterated test
(let ((lnktarget (conc lnkpath "/" item-path)))
(debug:print 2 "Setting up sub test run area")
(debug:print 2 " - creating run area in " test-path)
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
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
707
708
709
710
711
712
713
714
715
716
|
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
(create-symbolic-link toptest-path lnkpath)))
;; NB - This was not working right - some top tests are not getting the path set!!!
;;
;; Do the setting of this record after the paths are created so that the shortdir can
;; be set to the real directory location. This is safer for future clean up if the link
;; tree is damaged or lost.
;;
(if (not (hash-table-ref/default *toptest-paths* testname #f))
(let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path))
(curr-test-path (if testinfo ;; (filedb:get-path *fdb*
;; (db:get-path dbstruct
;; (rmt:sdb-qry 'getstr
(db:test-get-rundir testinfo) ;; ) ;; )
#f)))
(hash-table-set! *toptest-paths* testname curr-test-path)
;; NB// Was this for the test or for the parent in an iterated test?
(rmt:general-call 'test-set-rundir-shortdir run-id lnkpath
(if (file-exists? lnkpath)
(resolve-pathname lnkpath)
lnkpath)
testname "")
;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
(handle-exceptions
exn
#f ;; don't care to catch and deal with errors here for now.
(create-directory toptest-path #t))
(hash-table-set! *toptest-paths* testname toptest-path)))))
;; The toptest path has been created, the link to the test in the linktree has
;; been created. Now, if this is an iterated test the real test dir must be created
(if (not not-iterated) ;; this is an iterated test
(begin ;; (let ((lnktarget (conc lnkpath "/" item-path)))
(debug:print 2 "Setting up sub test run area")
(debug:print 2 " - creating run area in " test-path)
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
|
| ︙ | | | ︙ | |
603
604
605
606
607
608
609
610
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
636
637
638
639
640
641
642
|
exn
(begin
(debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit))
(if (symbolic-link? lnktarget) (delete-file lnktarget))
(if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
;; I suspect this section was deleting test directories under some
;; wierd sitations? This doesn't make sense - reenabling the rm -f
;; I honestly don't remember *why* this chunk was needed...
;; (let ((testlink (conc lnkpath "/" testname)))
;; (if (and (file-exists? testlink)
;; (or (regular-file? testlink)
;; (symbolic-link? testlink)))
;; (system (conc "rm -f " testlink)))
;; (system (conc "ln -sf " test-path " " testlink)))
(if (directory? test-path)
(begin
(let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
(if cmd
;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
(string-substitute "TEST_TARG_PATH" test-path
(string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
#f)))
(cmd (if ovrcmd
ovrcmd
(conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
" >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
(status (system cmd)))
(if (not (eq? status 0))
(debug:print 2 "ERROR: problem with running \"" cmd "\"")))
(list lnkpathf lnkpath ))
(list #f #f))))
;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area
;; 4. remotely run the test on allocated host
;; - could be ssh to host from hosts table (update regularly with load)
;; - could be netbatch
|
|
|
|
<
<
<
<
<
<
>
>
>
>
>
|
|
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
|
exn
(begin
(debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit))
(if (symbolic-link? lnktarget) (delete-file lnktarget))
(if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
(if (not (directory? test-path))
(create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes
(if (directory? test-path)
(begin
(let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
(if cmd
;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
(string-substitute "TEST_TARG_PATH" test-path
(string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
#f)))
(cmd (if ovrcmd
ovrcmd
(conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
" >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
(status (system cmd)))
(if (not (eq? status 0))
(debug:print 2 "ERROR: problem with running \"" cmd "\"")))
(list lnkpathf lnkpath ))
(if (> remtries 0)
(begin
(debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries)
;;
(create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1)))
(list #f #f)))))
;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area
;; 4. remotely run the test on allocated host
;; - could be ssh to host from hosts table (update regularly with load)
;; - could be netbatch
|
| ︙ | | | ︙ | |
684
685
686
687
688
689
690
691
692
693
694
695
696
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
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
|
(work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
(testinfo (cdb:get-test-info-by-id *runremote* test-id))
(mt_target (string-intersperse (map cadr keyvals) "/"))
(debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
(if (args:get-arg "-logging")(list "-logging") '()))))
(setenv "MT_ITEMPATH" item-path)
(if hosts (set! hosts (string-split hosts)))
;; set the megatest to be called on the remote host
(if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
(set! mt-bindir-path (pathname-directory remote-megatest))
(if launcher (set! launcher (string-split launcher)))
;; set up the run work area for this test
(if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
(not (equal? (db:test-get-rundir testinfo) "n/a"))) ;; n/a is a placeholder and thus not a read dir
(begin
(debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
(runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record
(set! diskpath (get-best-disk *configdat*))
(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))
(set! toptest-work-area (cadr dat))
(debug:print-info 2 "Using work area " work-area))
(begin
(set! work-area (conc test-path "/tmp_run"))
(create-directory work-area #t)
(debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
(set! cmdparms (base64:base64-encode
(with-output-to-string
(lambda () ;; (list 'hosts hosts)
(write (list (list 'testpath test-path)
;; (list 'runremote *runremote*)
(list 'transport (conc *transport-type*))
(list 'serverinf *server-info*)
(list 'toppath *toppath*)
(list 'work-area work-area)
(list 'test-name test-name)
(list 'runscript runscript)
(list 'run-id run-id )
(list 'test-id test-id )
(list 'itemdat itemdat )
(list 'megatest remote-megatest)
(list 'ezsteps ezsteps)
(list 'target mt_target)
(list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
(list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '()))
(list 'set-vars (if params (hash-table-ref/default params "-setvars" #f)))
(list 'runname runname)
(list 'mt-bindir-path mt-bindir-path)))))))
;; clean out step records from previous run if they exist
;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
;; (open-run-close db:delete-test-step-records db test-id)
(tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
|
|
|
|
>
>
>
>
>
>
|
|
|
<
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
>
<
|
<
|
804
805
806
807
808
809
810
811
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
|
(work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
(testinfo (rmt:get-test-info-by-id run-id test-id))
(mt_target (string-intersperse (map cadr keyvals) "/"))
(debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
(if (args:get-arg "-logging")(list "-logging") '()))))
(setenv "MT_ITEMPATH" item-path)
(if hosts (set! hosts (string-split hosts)))
;; set the megatest to be called on the remote host
(if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
(set! mt-bindir-path (pathname-directory remote-megatest))
(if launcher (set! launcher (string-split launcher)))
;; set up the run work area for this test
(if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
(not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
(begin
(debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
(runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record
;; prevent overlapping actions - set to LAUNCHED as early as possible
;;
(tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED")
(set! diskpath (get-best-disk *configdat*))
(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))
(set! toptest-work-area (cadr dat))
(debug:print-info 2 "Using work area " work-area))
(begin
(set! work-area (conc test-path "/tmp_run"))
(create-directory work-area #t)
(debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
(set! cmdparms (base64:base64-encode
(z3:encode-buffer
(with-output-to-string
(lambda () ;; (list 'hosts hosts)
(write (list (list 'testpath test-path)
(list 'transport (conc *transport-type*))
;; (list 'serverinf *server-info*)
(list 'toppath *toppath*)
(list 'work-area work-area)
(list 'test-name test-name)
(list 'runscript runscript)
(list 'run-id run-id )
(list 'test-id test-id )
;; (list 'item-path item-path )
(list 'itemdat itemdat )
(list 'megatest remote-megatest)
(list 'ezsteps ezsteps)
(list 'target mt_target)
(list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
(list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '()))
(list 'set-vars (if params (hash-table-ref/default params "-setvars" #f)))
(list 'runname runname)
(list 'mt-bindir-path mt-bindir-path))))))))
;; clean out step records from previous run if they exist
;; (rmt:delete-test-step-records run-id test-id)
(change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
(cond
((and launcher hosts) ;; must be using ssh hostname
(set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
(launcher
(set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))
|
| ︙ | | | ︙ | |