Changes In Branch v1.81
Excluding Merge-Ins
This is equivalent to a diff from
da872f4237
to 49fc46636e
Modified Makefile
from [ff04dd969e]
to [b89c1a12c0].
︙ | | |
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
|
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
|
+
-
+
-
|
recent-commits.csv : .fslckout
fossil timeline -n 350 -t ci -F "%h,%a,%b,%t,\"%c\"" > recent-commits.csv
SHELL=/bin/bash
PREFIX=$(PWD)
# CSCOPTS=-lfa2 -specialize -inline-global
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
tdb.scm mt.scm \
ezsteps.scm rmt.scm api.scm \
subrun.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm adjutant.scm mutils.scm mttop.scm tcp-transportmod.scm rmtmod.scm portlogger.scm
tcp-transportmod.scm rmtmod.scm portlogger.scm
transport-mode.scm : transport-mode.scm.template
cp transport-mode.scm.template transport-mode.scm
dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm
|
︙ | | |
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
-
+
|
@mkdir -p mofiles
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
@if [[ -e $*.import.scm ]];then touch $*.import.scm;fi # ensure it is touched after the .o is made
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
MTESTHASH=$(shell if [[ -e .fslckout ]];then fossil info|grep checkout:| awk '{print $$2}';else echo "na";fi)
ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif
# CSIPATH=$(shell which csi)
# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
|
︙ | | |
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
-
+
|
mkdir -p $(PREFIX)/share/docs
$(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html
for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done
# add a fake dependency so this doens't copy everytime
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout
mkdir -p $(PREFIX)/share/js
fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js
cp utils/java-script-lib $(PREFIX)/share/js/jquery-3.1.0.slim.min.js
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
|
︙ | | |
337
338
339
340
341
342
343
344
345
346
347
348
349
350
|
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
|
+
+
+
|
$(INSTALL) $< $@
chmod a+x $@
$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh
$(INSTALL) $< $@
chmod a+x $@
$(PREFIX)/bin/convert-db.sh : utils/convert-db.sh
$(INSTALL) $< $@
chmod a+x $@
deploytarg/nbfake : utils/nbfake
$(INSTALL) $< $@
chmod a+x $@
deploytarg/viewscreen : utils/viewscreen
$(INSTALL) $< $@
|
︙ | | |
383
384
385
386
387
388
389
390
391
392
393
394
395
396
|
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
|
+
|
$(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \
fi
install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
$(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
$(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
$(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
$(PREFIX)/bin/convert-db.sh $(PREFIX)/bin/convert-db.sh \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
$(PREFIX)/share/db/mt-pg.sql \
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 $(PREFIX)/bin/serialize-env
|
︙ | | |
Modified adjutant.scm
from [7560fecb1c]
to [d6c67b1549].
︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
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
|
-
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (unit adjutant))
(module adjutant *
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
md5 message-digest
md5 message-digest matchable
regex srfi-1)
(define (adjutant-run)
(print "Running the adjutant!"))
(define (adjutant-run host-type rmt:no-sync-take-job)
(print "Running the adjutant!")
(let loop ((wait-count 0))
(if (< wait-count 10) ;; 6 x 10 seconds = one minute
(let* ((dat (rmt:no-sync-take-job host-type)))
(match dat
((id ht vars exekey cmdline state event-time last-update)
(system cmdline)
(loop 0))
(else
(thread-sleep! 10)
(loop (+ wait-count 1)))))
(print "I'm bored. Exiting."))))
)
|
Modified api.scm
from [b08fe263c7]
to [7f68d2f308].
︙ | | |
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
153
154
155
156
157
158
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
196
|
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
tasks-set-state-given-param-key
))
(define *db-write-mutexes* (make-hash-table))
(define *server-signature* #f)
(define *api-threads* '())
(define (api:register-thread th-in)
(set! *api-threads* (cons (cons th-in (current-seconds)) *api-threads*)))
(define (api:register-thread th-in command)
(set! *api-threads* (cons (list th-in (current-seconds) command) *api-threads*)))
(define (api:get-thread-command th-in)
(let ((thread-data (assoc th-in *api-threads*)))
(if thread-data
(third thread-data) ; Assuming the command is the third element in the list
#f))) ; Return #f if the thread is not found
(define (api:unregister-thread th-in)
(set! *api-threads* (filter (lambda (thdat)
(not (eq? th-in (car thdat))))
*api-threads*)))
(define (api:remove-dead-or-terminated)
(set! *api-threads* (filter (lambda (thdat)
(not (member (thread-state (car thdat)) '(terminated dead))))
*api-threads*)))
(define (api:get-count-threads-alive)
(length *api-threads*))
(define (api:get-threads)
(map (lambda (thdat)
(let ((thread (first thdat))
(timestamp (second thdat))
(command (third thdat)))
(format "\nThread: ~a, age: ~a, Command: ~a" thread (- (current-seconds) timestamp) command)))
*api-threads*))
(define *api:last-stats-print* 0)
(define *api-print-db-stats-mutex* (make-mutex))
(define (api:print-db-stats)
(debug:print-info 0 *default-log-port* "Started periodic db stats printer")
(let loop ()
(mutex-lock! *api-print-db-stats-mutex*)
|
︙ | | |
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
-
+
|
;; reads/writes to current in/out port
;;
(define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params)
(assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
(if (not *server-signature*)
(set! *server-signature* (tt:mk-signature *toppath*)))
(lambda (indat)
(api:register-thread (current-thread))
(api:register-thread (current-thread) (car indat))
(let* ((result
(let* ((numthreads (api:get-count-threads-alive))
(delay-wait (if (> numthreads 10)
(- numthreads 10)
0))
(normal-proc (lambda (cmd run-id params)
(case cmd
|
︙ | | |
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
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
|
241
242
243
244
245
246
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
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
|
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
-
-
|
((ping) #t) ;; we are fine
(else
(assert ok "FATAL: database file and run-id not aligned.")))))
(ttdat *server-info*)
(server-state (tt-state ttdat))
(maxthreads 20) ;; make this a parameter?
(status (cond
((and (> numthreads maxthreads)
(> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
'busy)
;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
((> numthreads maxthreads)
(let* ((testsuite (common:get-testsuite-name))
(mtexe (common:find-local-megatest))
(proc (lambda ()
;; we are overloaded, try to start another server
(debug:print 0 *default-log-port* "Too many threads running, starting another server")
(tt:server-process-run *toppath* testsuite mtexe run-id))))
(set! *server-start-requests* (cons proc *server-start-requests*)))
;; 'busy
'loaded ;; not ideal since the client will not backoff
)
(else 'ok)))
(errmsg (case status
((busy) (conc "Server overloaded, "numthreads" threads in flight"))
((busy) (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads)))
((loaded) (conc "Server loaded, "numthreads" threads in flight"))
(else #f)))
(result (case status
((busy)
(if (eq? cmd 'ping)
(normal-proc cmd run-id params)
;; numthreads must be greater than 5 for busy
(* 0.1 (- numthreads maxthreads)) ;; was 15
)) ;; (- numthreads 29)) ;; call back in as many seconds
((loaded)
;; (if (eq? (rmt:transport-mode) 'tcp)
;; (thread-sleep! 0.5))
(normal-proc cmd run-id params))
(else
(normal-proc cmd run-id params))))
(meta (case cmd
((ping) `((sstate . ,server-state)))
((ping) `((sstate . ,server-state)(sload . ,numthreads)))
(else `((wait . ,delay-wait)))))
(payload (list status errmsg result meta)))
;; (cmd run-id params meta)
(db:add-stats cmd run-id params (- (current-milliseconds) start-t))
payload))
(else
(assert #f "FATAL: failed to deserialize indat "indat))))))
;; (set! *api-process-request-count* (- *api-process-request-count* 1))
;; (serialize payload)
(api:unregister-thread (current-thread))
result)))
(define *api-halt-writes* #f)
(define (api:dispatch-request dbstruct cmd run-id params)
(if (not *no-sync-db*)
(db:open-no-sync-db))
(let* ((start-time (current-milliseconds)))
|
︙ | | |
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
|
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
|
+
+
+
-
+
|
((tasks-get-last) (apply tasks:get-last dbstruct params))
;; NO SYNC DB
((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params))
((no-sync-add-job) (apply db:no-sync-add-job *no-sync-db* params))
((no-sync-take-job) (apply db:no-sync-take-job *no-sync-db* params))
((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params))
;; NO SYNC DB PROCESSES
((register-process) (apply dbfile:register-process *no-sync-db* params))
((set-process-done) (apply dbfile:set-process-done *no-sync-db* params))
((set-process-status) (apply dbfile:set-process-status *no-sync-db* params))
((get-process-options) (apply dbfile:get-process-options *no-sync-db* params))
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
;;======================================================================
;; READ ONLY QUERIES
;;======================================================================
;; KEYS
((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
((get-keys) (db:get-keys dbstruct))
|
︙ | | |
Modified common.scm
from [5744dec10a]
to [5c226366fd].
︙ | | |
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
|
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
|
-
+
+
+
+
-
+
|
(use posix-extras pathname-expand files)
(import commonmod
debugprint
rmtmod
(prefix mtargs args:))
(define (remove-server-files directory-path)
(let ((files (glob (string-append directory-path "/server*"))))
(for-each delete-file* files)))
(include "common_records.scm")
(define (remove-files filespec)
(let ((files (glob filespec)))
(for-each delete-file* files)))
(define (stop-the-train)
(thread-start! (make-thread (lambda ()
(let loop ()
(if (and *toppath*
(file-exists? (conc *toppath*"/stop-the-train")))
(let* ((msg (conc "ERROR: found file "*toppath*"/stop-the-train, exiting immediately")))
;; yes, print to current-output-port AND *default-log-port*, annoying but necessary I think
(print msg)
(remove-server-files (conc *toppath* "/logs"))
(debug:print 0 *default-log-port* msg)
(remove-files (conc *toppath* "/logs/server*"))
(remove-files (conc *toppath* "/.servinfo/*"))
(remove-files (conc *toppath* "/.mtdb/*lock"))
(exit 1)))
(thread-sleep! 5)
(loop))))))
|
︙ | | |
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
|
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
|
-
-
+
+
+
+
-
-
-
+
+
-
-
-
+
+
-
-
|
(- megatest-version (common:get-last-run-version-number)))
(define (common:version-changed?)
(not (equal? (common:get-last-run-version)
(common:version-signature))))
;; From 1.70 to 1.80, db's are compatible.
;; From 1.70 to 1.81, db's are compatible.
;;
;; BUG: This logic is almost certainly not quite correct.
;;
(define (common:api-changed?)
(let* (
(megatest-major-version (substring (->string megatest-version) 0 4))
(run-major-version (substring (conc (common:get-last-run-version)) 0 4))
(let* ((megatest-major-version (substring (->string megatest-version) 0 4))
(run-major-version (substring (conc (common:get-last-run-version)) 0 4)))
)
(and (not (equal? megatest-major-version "1.80"))
(not (equal? megatest-major-version megatest-run-version)))
(and (not (member megatest-major-version '("1.81" "1.80")))
(not (equal? megatest-major-version run-major-version)))))
)
)
;;======================================================================
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
(case (rmt:transport-mode)
|
︙ | | |
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
|
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
|
-
+
|
(sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b))))))
))
;;======================================================================
;; E N V I R O N M E N T V A R S
;;======================================================================
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME")))
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME" "PROMPT_COMMAND")))
;;(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
|
︙ | | |
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
|
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
|
+
+
+
+
-
+
+
-
-
+
+
+
+
+
-
+
-
+
+
+
+
+
-
+
|
;;
;; [hosts]
;; arm cubie01 cubie02
;; x86_64 zeus xena myth01
;; allhosts #{g hosts arm} #{g hosts x86_64}
;;
;; [host-types]
;; C/M/A lets megatest know this launcher provides C cores, M bytes memory for architecture A
;; 2/2G/arm smart -cores 2 -memory 2G -arch arm
;; general #MTLOWESTLOAD #{g hosts allhosts}
;; arm #MTLOWESTLOAD #{g hosts arm}
;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
;;
;; NOTE: host-rules is ONLY used for MTLOWESTLOAD
;;
;; [host-rules]
;; # maxnload => max normalized load
;; # maxnjobs => max jobs per cpu
;; # maxjobrate => max jobs per second
;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1
;;
;; [launchers]
;; envsetup general
;; xor/%/n 4C16G
;; xor/%/n 2/2G/arm
;; % nbgeneral
;;
;; [jobtools]
;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
;; flexi-launcher yes
;; launcher nbfake
;; mode adjutant|normal (default is normal)
;;
(define (common:get-launcher configdat testname itempath)
;;
;;
;; mode is 'normal (i.e. directly use launcher) or 'adjutant (i.e. use adjutant)
;;
(define (common:get-launcher configdat testname itempath mode)
(let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
(if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
(not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
(let* ((launchers (hash-table-ref/default configdat "launchers" '())))
(if (null? launchers)
fallback-launcher
(let loop ((hed (car launchers))
(tal (cdr launchers)))
(let ((patt (car hed))
(host-type (cadr hed)))
(if (tests:match patt testname itempath)
(if (tests:match patt testname itempath) ;; have a launcher match for this test
(begin
(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
(let ((launcher (configf:lookup configdat "host-types" host-type)))
(let ((launcher (configf:lookup configdat "host-types" host-type))) ;; find the actual launcher from the host-types table
;; if we are in adjutant mode then we want to return both host-type and launcher
(if launcher
(let* ((launcher-parts (string-split launcher))
(launcher-exe (car launcher-parts)))
(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
(let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
(count 100))
(if targ-host
(conc "remrun " targ-host)
(if (> count 0)
(begin
(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
(thread-sleep! (- 101 count))
(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
(- count 1)))
(begin
(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
(exit)))))
(case mode
((adjutant) (list host-type launcher))
launcher))
(else launcher))))
(begin
(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
(if (null? tal)
fallback-launcher
(loop (car tal)(cdr tal)))))))
;; no match, try again
(if (null? tal)
|
︙ | | |
Modified dashboard-tests.scm
from [ceec46e3cb]
to [9ace3eb7d8].
︙ | | |
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
-
+
+
|
(list "Testname: "
"Item path: "
"Current state: "
"Current status: "
"Test comment: "
"Test id: "
"Test date: "))
(list (iup:label "" #:expand "VERTICAL"))))
(list (iup:label "" #:expand "VERTICAL"
))))
(apply iup:vbox ; #:expand "YES"
(list
(store-label "testname"
(iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL")
(lambda (testdat)(db:test-get-testname testdat)))
(store-label "item-path"
(iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL")
|
︙ | | |
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
|
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
|
-
+
+
-
+
+
|
(iup:label val ; #:expand "HORIZONTAL"
))
(list "Author: "
"Owner: "
"Reviewed: "
"Tags: "
"Description: "))
(list (iup:label "" #:expand "VERTICAL"))))
(list (iup:label "" #:expand "VERTICAL"
))))
(apply iup:vbox ; #:expand "YES"
(list
(store-meta "author"
(iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL")
(lambda (testmeta)(db:testmeta-get-author testmeta)))
(store-meta "owner"
(iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL")
(lambda (testmeta)(db:testmeta-get-owner testmeta)))
(store-meta "reviewed"
(iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL")
(lambda (testmeta)(db:testmeta-get-reviewed testmeta)))
(store-meta "tags"
(iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL")
(lambda (testmeta)(db:testmeta-get-tags testmeta)))
(store-meta "description"
(iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL")
(iup:label (test-meta-panel-get-description testmeta) ;; #:wordwrap "YES" ;; #:size "x50"
) ;; #:expand "HORIZONTAL")
(lambda (testmeta)
(test-meta-panel-get-description testmeta)))
)))))
;;======================================================================
;; Run info panel
|
︙ | | |
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
+
-
+
+
+
+
-
+
+
-
+
+
|
(iup:label (conc (car keyval) " ")))
keydat)
(list (iup:label "runname ")
(iup:label "run-id")
(iup:label "run-date"))))
(apply iup:vbox
(append (map (lambda (keyval)
(iup:vbox
(iup:label (cadr keyval) #:expand "HORIZONTAL"))
(iup:label (cadr keyval) #:expand "HORIZONTAL")
;; (iup:label "" #:expand "BOTH")
)
)
keydat)
(list (iup:label runname)
(iup:label (conc run-id))
(iup:label (seconds->year-work-week/day-time event_time))
(iup:label "" #:expand "VERTICAL"))))))))
(iup:label "" ;;#:expand "VERTICAL"
))))))))
;;======================================================================
;; Host info panel
;;======================================================================
(define (host-info-panel testdat store-label)
(iup:frame
#:title "Remote host and Test Run Info" ; #:expand "YES"
(iup:hbox ; #:expand "YES"
(apply iup:vbox ; #:expand "YES" ;; The heading labels
(append (map (lambda (val)
(iup:label val ; #:expand "HORIZONTAL"
))
(list "Hostname: "
"Disk free: "
"CPU Load: "
"Run duration: "
"Logfile: "
"Top process id: "
"Uname -a: "))
(iup:label "" #:expand "VERTICAL")))
(iup:label "" ;; #:expand "VERTICAL"
)))
(apply iup:vbox ; #:expand "YES"
(list
;; NOTE: Yes, the host can change!
(store-label "HostName"
(iup:label ;; (sdb:qry 'getstr
(db:test-get-host testdat) ;; )
#:expand "HORIZONTAL")
|
︙ | | |
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
|
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
|
-
-
-
+
+
+
-
-
+
+
+
+
|
;; if there is a submegatest create a button to launch dashboard in that area
;;
(define (submegatest-panel dbstruct keydat testdat runname testconfig)
(let* ((test-run-dir (db:test-get-rundir testdat))
(subarea (subrun:get-runarea test-run-dir))
(area-exists (and subarea (common:file-exists? subarea silent: #t))))
(if subarea
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:frame
#:title "Megatest Run Info" ;; #:expand "HORIZONTAL"
(if subarea
(iup:button
"Launch Dashboard"
#:action (lambda (obj)
(subrun:launch-dashboard test-run-dir))))
(iup:vbox))))
(subrun:launch-dashboard test-run-dir)))
(iup:vbox
(iup:label "Not a subrun..." #:expand "HORIZONTAL")
)))))
;; use a global for setting the buttons colors
;; state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
(let* ((state (db:test-get-state testdat))
(status (db:test-get-status testdat))
|
︙ | | |
669
670
671
672
673
674
675
676
677
678
679
680
681
682
|
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
|
+
+
+
+
+
+
+
+
+
|
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -target " keystring " -runname " runname
" -run -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -clean-cache"
))))
(rerun-clean (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -target " keystring " -runname " runname
" -rerun-clean -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -clean-cache"
))))
(remove-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
|
︙ | | |
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
751
|
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
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
|
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
|
((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1)))
((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
(else
;; (test-set-status! db run-id test-name state status itemdat)
(set! self ;
(iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title testfullname
(iup:vbox
(iup:hbox
(iup:vbox ; #:expand "YES"
;; The run and test info
(iup:hbox ; #:expand "YES"
(run-info-panel dbstruct keydat testdat runname)
(test-info-panel testdat store-label widgets)
(test-meta-panel testmeta store-meta))
(iup:hbox
(host-info-panel testdat store-label)
(submegatest-panel dbstruct keydat testdat runname testconfig))
(iup:vbox ; #:expand "YES"
;; The run and test info
(iup:hbox ; #:expand "YES"
(run-info-panel dbstruct keydat testdat runname)
(test-info-panel testdat store-label widgets))
(host-info-panel testdat store-label))
(iup:vbox
(test-meta-panel testmeta store-meta)
(submegatest-panel dbstruct keydat testdat runname testconfig)))
;; The controls
(iup:frame #:title "Actions"
(iup:hbox ;; frame #:title "Actions"
(iup:vbox
(iup:hbox
(iup:button "View Log" #:action viewlog #:size "80x")
(iup:button "Start Xterm" #:action xterm #:size "80x")
(iup:button "Run Test" #:action run-test #:size "80x")
(iup:button "Clean Test" #:action remove-test #:size "80x")
(iup:hbox
(iup:frame
#:title "Immediate"
(iup:hbox
(iup:button "Start Xterm" #:action xterm #:size "80x")
(iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x")
(iup:button "View Log" #:action viewlog #:size "80x")))
(iup:frame
#:title "Command line"
(iup:hbox
(iup:button "Run Test" #:action run-test #:size "80x")
(iup:button "Rerun-clean" #:action rerun-clean #:size "80x")
(iup:button "Clean Test" #:action remove-test #:size "80x")
(iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x")
(iup:button "Kill All Jobs" #:action kill-jobs #:size "80x")
(iup:button "Archive Test" #:action archive-test #:size "80x")
(iup:button "Close" #:action (lambda (x)(exit)) #:size "80x"))
(iup:button "Kill All Jobs" #:action kill-jobs #:size "80x")))
(iup:label "" #:expand "HORIZONTAL")
(iup:frame
#:title "Other"
(iup:hbox
;; (iup:button "Archive Test" #:action archive-test #:size "80x")
(iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")
)))
(apply
iup:hbox
(list command-text-box command-launch-button))))
(set-fields-panel dbstruct run-id test-id testdat)
(let ((tabs
(iup:tabs
;; Replace here with matrix
|
︙ | | |
Modified dashboard.scm
from [e5b27b795a]
to [89bc431aeb].
︙ | | |
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
+
+
|
;; please-update: #t
;; update-mutex: (make-mutex)
;; updaters: (make-hash-table)
;; updating: #f
;; hide-not-hide-tabs: #f
;; target: ""
;; ))
(set! *journal-stats-enable* #f)
;;======================================================================
;; buttons color using image
;;======================================================================
(define *images* (make-hash-table))
|
︙ | | |
Modified db.scm
from [346b188c56]
to [4d25c1f0fd].
︙ | | |
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
|
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
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
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; (db:delay-if-busy dbdat)
(sqlite3:execute db "VACUUM;")
dead-runs))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;
(define (db:no-sync-db db-in)
(mutex-lock! *db-access-mutex*)
(let ((res (if db-in
db-in
(let ((db (db:open-no-sync-db)))
(set! *no-sync-db* db)
db))))
(mutex-unlock! *db-access-mutex*)
res))
(define (db:get-dbsync-path)
(case (rmt:transport-mode)
((http)(common:make-tmpdir-name *toppath* ""))
((tcp) (conc *toppath*"/.mtdb"))
((nfs) (conc *toppath*"/.mtdb"))
(else "/tmp/dunno-this-gonna-exist")))
(define (db:no-sync-add-job db-in host-type vars-list exekey cmdline)
(sqlite3:execute (db:no-sync-db db-in) "INSERT INTO jobs_queue (host_type,vars,exekey,cmdline,state,event_time,last_update) VALUES (?,?,?,?,?,?,?);"
host-type
(with-output-to-string
(lambda ()
(write vars-list)))
exekey cmdline "waiting" (current-seconds)(current-seconds)))
;; find next job (waiting longest) that matches host-type - future, we'll find jobs that fit if no exact match
(define (db:no-sync-take-job db-in host-type)
(let* ((db (db:no-sync-db db-in))
(stmt1 "SELECT id,host_type,vars,exekey,cmdline,state,event_time,last_update FROM jobs_queue WHERE host_type=? AND state != 'taken' ORDER BY event_time ASC;")
(stmt1h (sqlite3:prepare db stmt1))
(stmt2 "UPDATE jobs_queue SET state='taken',last_update=? WHERE id=?;")
(stmt2h (sqlite3:prepare db stmt2))
(res (sqlite3:with-transaction
db
(lambda ()
(let* ((matching-jobs (sqlite3:fold-row
(lambda (res . row) ;; id host-type vars exekey state event-time last-update)
(cons row res))
'()
stmt1h
host-type)))
(if (null? matching-jobs)
#f
(let ((choosen-one (let loop ((tal matching-jobs)
(res #f)) ;; put bestest one in here
(if (null? tal)
res
(let ((curr (car tal))
(rem (cdr tal)))
curr) ;; here we will compare with res, if better candidate the loop with curr else loop with res
))))
(if choosen-one ;; we need to mark it as taken
(sqlite3:execute stmt2h (current-seconds) (car choosen-one)))
choosen-one)))))))
(sqlite3:finalize! stmt1h) ;; it'd be nice to cache these and finalize on exit.
(sqlite3:finalize! stmt2h)
res))
;; clean out old jobs in queue, i.e. taken and event_time > 24 hrs ago
;;
(define (db:no-sync-job-records-clean db)
(sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600))))
(define (db:no-sync-get/default db-in var default)
(let ((db (db:no-sync-db db-in))
(res default))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
(db:no-sync-db db)
"SELECT val FROM no_sync_metadat WHERE var=?;"
var)
(if res
(let ((newres (if (string? res)
(string->number res)
#f)))
(if newres
newres
res))
res)))
;; This is needed for api.scm
(define (db:open-no-sync-db)
(dbfile:open-no-sync-db (db:get-dbsync-path)))
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
|
︙ | | |
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
|
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
db
"SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
run-id))))
;; Update run_stats for given run_id
;; input data is a list (state status count)
;;
(define (db:update-run-stats dbstruct run-id stats)
(mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
#f
#t
(lambda (dbdat db)
;; remove previous data
(let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
(stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
(res
(sqlite3:with-transaction
db
(lambda ()
(for-each
(lambda (dat)
(sqlite3:execute stmt1 run-id (car dat)(cadr dat))
(apply sqlite3:execute stmt2 run-id dat))
stats)))))
(sqlite3:finalize! stmt1)
(sqlite3:finalize! stmt2)
(mutex-unlock! *db-transaction-mutex*)
res))))
(define (db:update-run-stats dbstruct run-id stats-in)
(let* ((stats (if (list? stats-in)
stats-in
(db:get-raw-run-stats dbstruct run-id))))
(mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
#f
#t
(lambda (dbdat db)
;; remove previous data
(let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
(stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
(res
(sqlite3:with-transaction
db
(lambda ()
(for-each
(lambda (dat)
(sqlite3:execute stmt1 run-id (car dat)(cadr dat))
(apply sqlite3:execute stmt2 run-id dat))
stats)))))
(sqlite3:finalize! stmt1)
(sqlite3:finalize! stmt2)
(mutex-unlock! *db-transaction-mutex*)
res)))))
(define (db:get-main-run-stats dbstruct run-id)
(db:with-db
dbstruct
#f ;; this data comes from main
#f
(lambda (dbdat db)
|
︙ | | |
Modified dbfile.scm
from [fd3c73f7ce]
to [32ab28635d].
︙ | | |
548
549
550
551
552
553
554
555
556
557
558
559
560
561
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; I have been having trouble with init of no-sync.db so
;; doing the init in a transaction every time (no gating
;; on file existance.
(for-each
(lambda (stmt)
(sqlite3:execute db stmt))
(list
"CREATE TABLE IF NOT EXISTS jobs_queue
(id INTEGER PRIMARY KEY,
host_type TEXT,
cores INTEGER,
memory TEXT,
vars TEXT,
exekey TEXT,
cmdline TEXT,
state TEXT,
event_time INTEGER,
last_update INTEGER);"
"CREATE TABLE IF NOT EXISTS test_extra_data
(id INTEGER PRIMARY KEY,
run_id INTEGER,
test_id INTEGER,
last_seen_running INTEGER);"
"CREATE TABLE IF NOT EXISTS no_sync_metadat
(var TEXT,
val TEXT,
CONSTRAINT no_sync_metadat_constraint UNIQUE (var));"
"CREATE TABLE IF NOT EXISTS no_sync_locks
(key TEXT,
val TEXT,
|
︙ | | |
Modified docs/Makefile
from [c01320f2b0]
to [fc2e46e5a1].
︙ | | |
31
32
33
34
35
36
37
|
31
32
33
34
35
36
37
38
39
40
|
+
+
+
|
fossil add html/*
megatest.pdf : megatest.lyx
lyx -e pdf2 megatest.lyx
pkts.pdf : pkts.dot
dot -Tpdf pkts.dot -o pkts.pdf
stepwise.pdf : stepwise-rpc-via-direct-and-tcp-or-http.dot
dot stepwise-rpc-via-direct-and-tcp-or-http.dot -Tpdf -o stepwise.pdf
|
Added docs/csirc version [ab27eade5c].
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(cond-expand
(chicken-4
;; chicken 4 stuff here
(use readline)
(current-input-port (make-readline-port))
(install-history-file #f "/.csi.history")
)
(chicken-5
(import (chicken load))
(import (chicken format))
(import (chicken process-context))
(import (chicken process signal))
(load-verbose #f)
(let ()
(unless (get-environment-variable "INSIDE_EMACS")
(import breadline)
(import breadline-scheme-completion)
(history-file (format "~a/.csi_history" (get-environment-variable "HOME")))
(stifle-history! 10000)
(completer-word-break-characters-set! "\"\'`;|(")
(completer-set! scheme-completer)
(basic-quote-characters-set! "\"|")
(variable-bind! "blink-matching-paren" "on")
(paren-blink-timeout-set! 200000)
(let ((handler (signal-handler signal/int)))
(set-signal-handler! signal/int
(lambda (s)
(cleanup-after-signal!)
(reset-after-signal!)
(handler s))))
(on-exit reset-terminal!)
(current-input-port (make-readline-port))))
))
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
Added docs/megatest-training-1.odp version [3a112130cd].
cannot compute difference between binary files
Modified docs/megatest-training.odp
from [3a112130cd]
to [570b812b2b].
cannot compute difference between binary files
Added docs/stepwise-rpc-via-direct-and-tcp-or-http.dot version [a96a45b2ca].