Overview
Context
Changes
Modified db.scm
from [3d74afb53d]
to [e04dda63c7].
︙ | | |
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
-
+
|
(db:done-with dbstruct run-id r/w)
res)))
;;======================================================================
;; K E E P F I L E D B I N dbstruct
;;======================================================================
(define (db:get-filedb dbstruct)
(define (db:get-filedb dbstruct run-id)
(let ((db (vector-ref dbstruct 2)))
(if db
db
(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
(vector-set! dbstruct 2 fdb)
fdb))))
|
︙ | | |
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
+
+
+
+
+
-
|
(db (sqlite3:open-database dbpath))
(write-access (file-write-access? dbpath))
(handler (make-busy-timeout 136000)))
(if (and dbexists (not write-access))
(set! *db-write-access* #f)) ;; only unset so other db's also can use this control
(if write-access
(begin
(if (not dbexists)
(begin
(db:initialize-run-id-db db)
(sdb:initialize db)
)) ;; add strings db to rundb, not in use yet
(sqlite3:set-busy-handler! db handler)
(sqlite3:execute db "PRAGMA synchronous = 0;")))
(if (not dbexists)(db:initialize-run-id-db db))
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'rundb db)
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #t)
(if local
db
(begin
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem inmem)
(db:sync-tables db:sync-tests-only db inmem)
|
︙ | | |
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
+
+
+
+
+
+
+
+
+
|
(begin
(sqlite3:set-busy-handler! db handler)
(sqlite3:execute db "PRAGMA synchronous = 0;")))
(if (not dbexists)
(db:initialize-megatest-db db))
(dbr:dbstruct-set-main! dbstruct db)
db))))
;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
(define (db:setup)
(let ((dbstruct (make-dbr:dbstruct path: *toppath*)))
(db:get-db dbstruct #f) ;; force one call to main
(set! sdb:qry (make-sdb:qry (conc *toppath* "/db/strings.db"))) ;; we open the normalization helpers here
(set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
dbstruct))
;; sync all touched runs to disk
(define (db:sync-touched dbstruct)
(for-each
(lambda (runvec)
(let ((mtime (vector-ref runvec (dbr:dbstruct-field-name->num 'mtime)))
(stime (vector-ref runvec (dbr:dbstruct-field-name->num 'stime)))
|
︙ | | |
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
192
193
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
|
-
+
+
+
+
-
-
+
+
+
|
(sqlite3:finalize! (db:get-db dbstruct #f))
(for-each
(lambda (runvec)
(let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb))))
(if (sqlite3:database? rundb)
(sqlite3:finalize! rundb)
(debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database"))))
(hash-table-values (vector-ref dbstruct 1))))
(hash-table-values (vector-ref dbstruct 1)))
(sdb:qry 'finalize! #f)
(filedb:finalize-db! *fdb*))
(define (open-inmem-db)
(let* ((db (sqlite3:open-database ":memory:"))
(handler (make-busy-timeout 3600)))
(db:initialize-run-id-db db)
(sdb:initialize db) ;; for future use
(sqlite3:set-busy-handler! db handler)
(set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here
(set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
db))
;; just tests, test_steps and test_data tables
(define db:sync-tests-only
(list
(list "strs"
'("id" #f)
'("str" #f))
(list "tests"
'("id" #f)
'("run_id" #f)
'("testname" #f)
'("host" #f)
'("cpuload" #f)
'("diskfree" #f)
|
︙ | | |
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
|
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
|
-
+
-
+
|
(regexp "_") "=" msg #t))
(lambda ()(deserialize)))
(vector #f #f #f))) ;; crude reply for when things go awry
((zmq)(with-input-from-string msg (lambda ()(deserialize))))
(else msg)))
(define (db:test-set-status-state dbstruct run-id test-id status state msg)
(let ((db (db:get-db dbstruct rid)))
(let ((db (db:get-db dbstruct run-id)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
(db:general-call db 'set-test-start-time (list test-id)))
(if msg
(db:general-call db 'state-status-msg (list state status msg test-id))
(db:general-call db 'state-status (list state status test-id)))))
(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
(if (and (not (equal? item-path ""))
(member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
(let ((db (db:get-db dbstruct rid)))
(let ((db (db:get-db dbstruct run-id)))
(db:general-call db 'update-pass-fail-counts (list run-id test-name run-id test-name run-id test-name))
(if (equal? status "RUNNING")
(db:general-call db 'top-test-set-running (list run-id test-name))
(db:general-call db 'top-test-set-per-pf-counts (list run-id test-name run-id test-name run-id test-name)))
#f)
#f))
|
︙ | | |
Modified http-transport.scm
from [8511ea36d9]
to [c84c869b01].
︙ | | |
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
|
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
|
-
+
|
(let* ((th2 (make-thread (lambda ()
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-"))) "Server run"))
(th3 (make-thread http-transport:keep-running "Keep running")))
;; Database connection
(set! *inmemdb* (make-dbr:dbstruct path: *toppath*))
(set! *inmemdb* (db:setup))
(thread-start! th2)
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th2))
(debug:print 0 "ERROR: Failed to setup for megatest")))
(exit)))
|
︙ | | |
Modified launch.scm
from [207e8b581e]
to [e529e7dcc7].
︙ | | |
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
|
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
|
-
+
-
+
-
+
|
(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"
(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! test-id next-state "PASS" #f #f))
(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! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
(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))
|
︙ | | |
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
|
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
|
-
+
+
+
+
-
+
|
;; 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 (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:test-get-rundir testinfo)) #f)))
(curr-test-path (if testinfo ;; (filedb:get-path *fdb*
;; (db:get-path dbstruct
(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 "" (filedb:register-path *fdb* lnkpath)) ;; toptest-path)
(rmt:general-call 'test-set-rundir run-id lnkpath run-id testname "") ;; toptest-path)
(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)
(create-directory toptest-path #t)
(hash-table-set! *toptest-paths* testname toptest-path)))))
|
︙ | | |
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
|
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
|
-
+
|
(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)
(change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
(tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(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))))
|
︙ | | |
Modified megatest.scm
from [1e184de173]
to [6fa480ef4e].
︙ | | |
381
382
383
384
385
386
387
388
389
390
391
392
393
394
|
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
|
+
+
+
+
|
transport-from-config
"fs"))))
(debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
(case chosen-transport
((http)
(set! *transport-type 'http)
(server:ensure-running)
;; Get rid of this
(set! sdb:qry (make-sdb:qry (conc *toppath* "/db/strings.db"))) ;; we open the normalization helpers here
(set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
(client:launch))
(else ;; (fs)
(debug:print 0 "ERROR: Should NOT be getting here! fs transport is no longer supported")
(set! *transport-type* 'fs)
(set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
|
︙ | | |
Modified mt.scm
from [86cfab70c3]
to [ad70d7d352].
︙ | | |
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
-
-
-
+
+
+
+
|
res
(cons testn res)))))))))
;;======================================================================
;; T R I G G E R S
;;======================================================================
(define (mt:process-triggers test-id newstate newstatus)
(let* ((test-dat (rmt:get-test-info-by-id test-id))
(test-rundir (filedb:get-path *fdb* (db:test-get-rundir test-dat)))
(define (mt:process-triggers run-id test-id newstate newstatus)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(test-rundir ;; (filedb:get-path *fdb*
(db:test-get-rundir test-dat)) ;; )
(test-name (db:test-get-testname test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat))))
(if (and (file-exists? test-rundir)
(directory? test-rundir))
(begin
|
︙ | | |
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
-
+
|
(rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
((and newstate newstatus)
(rmt:general-call 'state-status run-id newstate newstatus test-id))
(else
(if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
(if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
(if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
(mt:process-triggers test-id newstate newstatus)
(mt:process-triggers run-id test-id newstate newstatus)
#t)
(define (mt:lazy-get-test-info-by-id test-id)
(let* ((tdat (hash-table-ref/default *test-info* test-id #f)))
(if (and tdat
(< (current-seconds)(+ (vector-ref tdat 0) 10)))
(vector-ref tdat 1)
|
︙ | | |
Modified rmt.scm
from [8b4a788096]
to [df4a047b28].
︙ | | |
254
255
256
257
258
259
260
261
262
263
264
265
|
254
255
256
257
258
259
260
261
262
263
264
265
|
-
-
+
+
|
(define (rmt:testmeta-get-record testname)
(rmt:send-receive 'testmeta-get-record (list testname)))
(define (rmt:testmeta-update-field test-name fld val)
(rmt:send-receive 'testmeta-update-field (list test-name fld val)))
(define (rmt:test-data-rollup test-id status)
(rmt:send-receive 'test-data-rollup (list test-id status)))
(define (rmt:test-data-rollup run-id test-id status)
(rmt:send-receive 'test-data-rollup (list run-id test-id status)))
(define (rmt:csv->test-data test-id csvdata)
(rmt:send-receive 'csv->test-data (list test-id csvdata)))
|
Modified sdb.scm
from [5d37256fc5]
to [0b5707be89].
︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
+
-
-
-
-
-
-
+
|
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit sdb))
;;
(define (sdb:open #!key (fname #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(define (sdb:open fname)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
(exit))))
(let* ((dbpath (conc *toppath* "/db/" (if fname fname "sdb.db"))) ;; fname)
(let* ((dbpath fname)
(dbexists (let ((fe (file-exists? dbpath)))
(if fe
fe
(begin
(create-directory (conc *toppath* "/db") #t)
#f))))
(sdb (sqlite3:open-database dbpath))
|
︙ | | |
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
-
-
+
+
-
+
|
(hash-table-set! id-cache id str))
sdb
"SELECT str FROM strs WHERE id=?;" id))
str))
;; Numbers get passed though in both directions
;;
(define (make-sdb:qry #!key (fname #f))
(let ((sdb #f) ;; (sdb:open fname: fname))
(define (make-sdb:qry fname)
(let ((sdb #f)
(scache (make-hash-table))
(icache (make-hash-table)))
(lambda (cmd var)
(if (not sdb)(set! sdb (sdb:open fname: fname)))
(if (not sdb)(set! sdb (sdb:open fname)))
(case cmd
((finalize) (if sdb
(begin
(sqlite3:finalize! sdb)
(set! sdb #f))))
((getid) (let ((id (if (or (number? var)
(string->number var))
|
︙ | | |
Modified tests.scm
from [4c09716113]
to [133fdce6ed].
︙ | | |
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
-
-
+
+
-
+
|
(set! real-status "WAIVED"))
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
(rmt:test-set-status-state test-id real-status state (if waived waived comment))
(mt:process-triggers test-id state real-status)))
(rmt:test-set-status-state run-id test-id real-status state (if waived waived comment))
(mt:process-triggers run-id test-id state real-status)))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, it does remote calls under the hood.
(if (and test-id state status (equal? status "AUTO"))
(rmt:test-data-rollup test-id status))
(rmt:test-data-rollup run-id test-id status))
;; add metadata (need to do this way to avoid SQL injection issues)
;; :first_err
;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
;; (if val
;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
|
︙ | | |
Modified tests/unittests/server.scm
from [b1c30eb42e]
to [0195ae0142].
︙ | | |
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
|
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
|
-
+
-
+
+
+
-
-
+
+
+
-
-
+
+
|
(define *keys* (keys:config-get-fields *configdat*))
(define *keyvals* (keys:target->keyval *keys* "a/b/c"))
(test #f #t (string? (car *runremote*)))
(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test
(test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test
;; RUNS
(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name)))
(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1)))
(vector-ref (vector-ref rinfo 1) 3)))
(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
;; TESTS
(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
(test "register test" #t (rmt:general-call 'register-test 1 "test1" ""))
(test "register test" #t (rmt:general-call 'register-test 1 1 "test1" ""))
(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
(test "get test id" 1 (rmt:get-test-id 1 "test1" ""))
(print "SKIPPING sync back for now")
(test "sync back" #t (> (rmt:sync-inmem->db) 0))
(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
;; (test "sync back" #t (> (rmt:sync-inmem->db) 0))
;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
(test "get keys" #t (list? (rmt:get-keys)))
(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
(test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t))
(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1)))
(db:test-get-comment trec)))
;; MORE RUNS
(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '()))
(header (vector-ref runs 0))
(data (vector-ref runs 1)))
(and (list? header)
|
︙ | | |