︙ | | |
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
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
|
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; R E C O R D S
;;======================================================================
;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
;; MERGED INTO *alldat*
;;
(defstruct dbr:dbstruct
(tmpdb #f)
(dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
) ;; goal is to converge on one struct for an area but for now it is too confusing
;; (defstruct dbr:dbstruct
;; (tmpdb #f)
;; (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
;; (mtdb #f)
;; (refndb #f)
;; (homehost #f) ;; not used yet
;; (on-homehost #f) ;; not used yet
;; (read-only #f)
;; ) ;; goal is to converge on one struct for an area but for now it is too confusing
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
|
︙ | | |
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
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
|
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
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
default
(begin
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
;; Get/open a database
;; if run-id => get run specific db
;; if #f => get main db
;; if db already open - return inmem
;; if db not open, open inmem, rundb and sync then return inmem
;; inuse gets set automatically for rundb's
;;
(define (db:get-db dbstruct) ;; run-id)
(if (stack? (dbr:dbstruct-dbstack dbstruct))
(if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
(let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area *alldat*))))
;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
newdb)
(stack-pop! (dbr:dbstruct-dbstack dbstruct)))
(db:open-db dbstruct)))
;; mod-read:
;; 'mod modified data
;; 'read read data
;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct
;;
;; (define (db:done-with dbstruct run-id mod-read)
;; (if (not (sqlite3:database? dbstruct))
;; (begin
;; (mutex-lock! *rundb-mutex*)
;; (if (eq? mod-read 'mod)
;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
;; (dbr:dbstruct-inuse-set! dbstruct #f)
;; (mutex-unlock! *rundb-mutex*))))
;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
(let* ((have-struct (dbr:dbstruct? dbstruct))
(dbdat (if have-struct
(db:get-db dbstruct)
#f))
(db (if have-struct
(db:dbdat-get-db dbdat)
dbstruct))
(use-mutex (> *api-process-request-count* 25)))
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
;; there is no recovering at this time. exit
(exit 50))
(if use-mutex (mutex-lock! *db-with-db-mutex*))
(let ((res (apply proc db params)))
(if use-mutex (mutex-unlock! *db-with-db-mutex*))
;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
(if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
res))))
;;======================================================================
;; K E E P F I L E D B I N dbstruct
;;======================================================================
;; (define (db:get-filedb dbstruct run-id)
;; (let ((db (vector-ref dbstruct 2)))
;; (if db
|
︙ | | |
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
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
|
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
(let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
(if (stack? tmpdb-stack)
(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
(let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
(dbpath (common:get-db-tmp-area *alldat* )) ;; path to tmp db area
(dbexists (common:file-exists? dbpath))
(tmpdbfname (conc dbpath "/megatest.db"))
(dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
(mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f))
(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (file-write-access? mtdbpath))
;;(mtdbmodtime (if mtdbexists
;;(common:lazy-sqlite-db-modification-time mtdbpath)
;;#f)) ; moving this before db:open-megatest-db is
;;called. if wal mode is on -WAL and -shm file get
;;created with causing the tmpdbmodtime timestamp
;;always greater than mtdbmodtime (tmpdbmodtime (if
;;dbfexists (common:lazy-sqlite-db-modification-time
;;tmpdbfname) #f))
;;if wal mode is on -WAL and -shm file get created when
;;db:open-megatest-db is called. modtimedelta will
;;always be < 10 so db in tmp not get synced
;;(tmpdbmodtime (if dbfexists (db:get-last-update-time
;;(car tmpdb)) #f)) (fmt (file-modification-time
;;tmpdbfname))
(modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(debug:print 0 *default-log-port* "ERROR: attempted to drop triggers on MTRA/megatest.db but failed. Error is " msg)
(set! write-access #f)) ;; if we failed to drop the triggers then we probably don't have write access
(when write-access
(sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
(sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")))
;;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime "
;;tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath*
;;"/megatest.db")) (debug:print-info 13 *default-log-port*
;;"db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists"
;;and write-access="write-access)
(if (and dbexists (not write-access))
(begin
(set! *db-write-access* #f)
(dbr:dbstruct-read-only-set! dbstruct #t)))
(dbr:dbstruct-mtdb-set! dbstruct mtdb)
(dbr:dbstruct-tmpdb-set! dbstruct tmpdb)
(dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; why a stack?
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
(dbr:dbstruct-refndb-set! dbstruct refndb)
;; (mutex-unlock! *rundb-mutex*)
(if (and (or (not dbfexists)
(and modtimedelta
(> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
(debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
;touch tmp db to avoid wal mode wierdness
(set! (file-modification-time tmpdbfname) (current-seconds))
(debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
)
(debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
(define (db:get-last-update-time db)
(let ((last-update-time #f))
(sqlite3:for-each-row
(lambda (lup)
(set! last-update-time lup))
db
"select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);")
last-update-time))
;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access.
;;
(define (db:setup do-sync #!key (areapath #f))
;;
(cond
(*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
(else ;;(common:on-homehost?)
(debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
(let* ((dbstruct (make-dbr:dbstruct)))
(when (not *toppath*)
(debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
(launch:setup areapath: areapath))
(debug:print-info 13 *default-log-port* "Begin db:open-db")
(db:open-db dbstruct areapath: areapath do-sync: do-sync)
(debug:print-info 13 *default-log-port* "Done db:open-db")
(set! *dbstruct-db* dbstruct)
;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
dbstruct))))
;; (else
;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
;; (exit 1))))
;; Open the classic megatest.db file (defaults to open in toppath)
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
;;(define (db:reopen-megatest-db
|
︙ | | |
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
|
325
326
327
328
329
330
331
332
333
334
335
336
337
338
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; (define (db:open-inmem-db)
;; (let* ((db (sqlite3:open-database ":memory:"))
;; (handler (make-busy-timeout 3600)))
;; (sqlite3:set-busy-handler! db handler)
;; (db:initialize-run-id-db db)
;; (cons db #f)))
;; 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)
'("uname" #f)
'("rundir" #f)
'("shortdir" #f)
'("item_path" #f)
'("state" #f)
'("status" #f)
'("attemptnum" #f)
'("final_logf" #f)
'("logdat" #f)
'("run_duration" #f)
'("comment" #f)
'("event_time" #f)
'("fail_count" #f)
'("pass_count" #f)
'("archived" #f)
'("last_update" #f))
(list "test_steps"
'("id" #f)
'("test_id" #f)
'("stepname" #f)
'("state" #f)
'("status" #f)
'("event_time" #f)
'("comment" #f)
'("logfile" #f)
'("last_update" #f))
(list "test_data"
'("id" #f)
'("test_id" #f)
'("category" #f)
'("variable" #f)
'("value" #f)
'("expected" #f)
'("tol" #f)
'("units" #f)
'("comment" #f)
'("status" #f)
'("type" #f)
'("last_update" #f))))
;; needs db to get keys, this is for syncing all tables
;;
(define (db:sync-main-list dbstruct)
(let ((keys (db:get-keys dbstruct)))
(list
(list "keys"
'("id" #f)
'("fieldname" #f)
'("fieldtype" #f))
(list "metadat" '("var" #f) '("val" #f))
(append (list "runs"
'("id" #f))
(map (lambda (k)(list k #f))
(append keys
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
(list "test_meta"
'("id" #f)
'("testname" #f)
'("owner" #f)
'("description" #f)
'("reviewed" #f)
'("iterated" #f)
'("avg_runtime" #f)
'("avg_disk" #f)
'("tags" #f)
'("jobgroup" #f)))))
(define (db:sync-all-tables-list dbstruct)
(append (db:sync-main-list dbstruct)
db:sync-tests-only))
;; use bunch of Unix commands to try to break the lock and recreate the db
;;
(define (db:move-and-recreate-db dbdat)
(let* ((dbpath (db:dbdat-get-path dbdat))
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath))
|
︙ | | |
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
|
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
(define (db:get-keys dbstruct)
(if *db-keys* *db-keys*
(let ((res '()))
(db:with-db dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (key)
(set! res (cons key res)))
db
"SELECT fieldname FROM keys ORDER BY id DESC;")))
(set! *db-keys* res)
res)))
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
(if (or (null? header) (not row))
#f
(let loop ((hed (car header))
(tal (cdr header))
(n 0))
|
︙ | | |
4757
4758
4759
4760
4761
4762
4763
4764
|
4510
4511
4512
4513
4514
4515
4516
4517
|
-
+
|
(stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
;; tiresome setup for rmtmod (and other mods) goes here
;; (set-fn 'db:dbfile-path common:get-db-tmp-area)
(set-fn 'db:setup db:setup)
(set-fn 'db:setup dbmod#db:setup)
|
︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
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
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
176
177
178
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
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
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
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (unit dbmod))
(declare (uses commonmod))
(module dbmod
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable stack)
(import commonmod)
;; (use (prefix ulex ulex:))
(include "common_records.scm")
;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
dbdat))
;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access.
;;
(define (db:setup do-sync alldat #!key (areapath #f))
(let* ((log-port (alldat-log-port alldat)))
(cond
((alldat-dbstack alldat) alldat) ;; already initialized
((not (alldat-areapath alldat)) ;; no top path yet? Just exit
(debug:print-info 13 log-port "in db:setup, area-path not set; give up and exit.")
(exit 1))
(else ;;(common:on-homehost?)
(debug:print-info 13 log-port "db:setup entered (first time, not cached.)")
(debug:print-info 13 log-port "Begin db:open-db")
(db:open-db alldat areapath: areapath do-sync: do-sync)
(debug:print-info 13 log-port "Done db:open-db")
;; (set! *dbstruct-db* dbstruct)
alldat))))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db alldat #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
(let ((tmpdb-stack (alldat-dbstack alldat))) ;; RA => Returns the first reference in alldat
(if (stack? tmpdb-stack)
(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
(let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
(dbpath (common:get-db-tmp-area alldat)) ;; path to tmp db area
(dbexists (common:file-exists? dbpath))
(tmpdbfname (conc dbpath "/megatest.db"))
(dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
(mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f))
(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (file-write-access? mtdbpath))
;;(mtdbmodtime (if mtdbexists
;;(common:lazy-sqlite-db-modification-time mtdbpath)
;;#f)) ; moving this before db:open-megatest-db is
;;called. if wal mode is on -WAL and -shm file get
;;created with causing the tmpdbmodtime timestamp
;;always greater than mtdbmodtime (tmpdbmodtime (if
;;dbfexists (common:lazy-sqlite-db-modification-time
;;tmpdbfname) #f))
;;if wal mode is on -WAL and -shm file get created when
;;db:open-megatest-db is called. modtimedelta will
;;always be < 10 so db in tmp not get synced
;;(tmpdbmodtime (if dbfexists (db:get-last-update-time
;;(car tmpdb)) #f)) (fmt (file-modification-time
;;tmpdbfname))
(modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(debug:print 0 log-port "ERROR: attempted to drop triggers on MTRA/megatest.db but failed. Error is " msg)
(set! write-access #f)) ;; if we failed to drop the triggers then we probably don't have write access
(when write-access
(sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
(sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")))
;;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime "
;;tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath*
;;"/megatest.db")) (debug:print-info 13 log-port
;;"db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists"
;;and write-access="write-access)
(if (and dbexists (not write-access))
(begin
(set! *db-write-access* #f)
(alldat-read-only-set! alldat #t)))
(alldat-mtdb-set! alldat mtdb)
(alldat-tmpdb-set! alldat tmpdb)
(alldat-dbstack-set! alldat (make-stack)) ;; why a stack?
(stack-push! (alldat-dbstack alldat) tmpdb) ;; olddb is already a (cons db path)
(alldat-refndb-set! alldat refndb)
;; (mutex-unlock! *rundb-mutex*)
(if (and (or (not dbfexists)
(and modtimedelta
(> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
(debug:print 1 log-port "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(db:sync-tables (db:sync-all-tables-list alldat) #f mtdb refndb tmpdb)
;touch tmp db to avoid wal mode wierdness
(set! (file-modification-time tmpdbfname) (current-seconds))
(debug:print-info 13 log-port "db:sync-all-tables-list done.")
)
(debug:print 4 log-port " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync alldat 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
;; Get/open a database
;; if run-id => get run specific db
;; if #f => get main db
;; if db already open - return inmem
;; if db not open, open inmem, rundb and sync then return inmem
;; inuse gets set automatically for rundb's
;;
(define (db:get-db alldat) ;; run-id)
(if (stack? (alldat-dbstack alldat))
(if (stack-empty? (alldat-dbstack alldat))
(let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area alldat))))
;; (stack-push! (alldat-dbstack alldat) newdb)
newdb)
(stack-pop! (alldat-dbstack alldat)))
(db:open-db alldat)))
(define (db:sync-all-tables-list alldat)
(append (db:sync-main-list alldat)
db:sync-tests-only))
;; 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)
'("uname" #f)
'("rundir" #f)
'("shortdir" #f)
'("item_path" #f)
'("state" #f)
'("status" #f)
'("attemptnum" #f)
'("final_logf" #f)
'("logdat" #f)
'("run_duration" #f)
'("comment" #f)
'("event_time" #f)
'("fail_count" #f)
'("pass_count" #f)
'("archived" #f)
'("last_update" #f))
(list "test_steps"
'("id" #f)
'("test_id" #f)
'("stepname" #f)
'("state" #f)
'("status" #f)
'("event_time" #f)
'("comment" #f)
'("logfile" #f)
'("last_update" #f))
(list "test_data"
'("id" #f)
'("test_id" #f)
'("category" #f)
'("variable" #f)
'("value" #f)
'("expected" #f)
'("tol" #f)
'("units" #f)
'("comment" #f)
'("status" #f)
'("type" #f)
'("last_update" #f))))
;; needs db to get keys, this is for syncing all tables
;;
(define (db:sync-main-list alldat)
(let ((keys (db:get-keys alldat)))
(list
(list "keys"
'("id" #f)
'("fieldname" #f)
'("fieldtype" #f))
(list "metadat" '("var" #f) '("val" #f))
(append (list "runs"
'("id" #f))
(map (lambda (k)(list k #f))
(append keys
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
(list "test_meta"
'("id" #f)
'("testname" #f)
'("owner" #f)
'("description" #f)
'("reviewed" #f)
'("iterated" #f)
'("avg_runtime" #f)
'("avg_disk" #f)
'("tags" #f)
'("jobgroup" #f)))))
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
(define (db:get-keys alldat)
(if *db-keys* *db-keys*
(let ((res '()))
(db:with-db alldat #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (key)
(set! res (cons key res)))
db
"SELECT fieldname FROM keys ORDER BY id DESC;")))
(set! *db-keys* res)
res)))
;; (db:with-db alldat run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db alldat run-id r/w proc . params)
(let* ((have-struct (alldat? alldat))
(dbdat (if have-struct
(db:get-db alldat)
#f))
(db (if have-struct
(db:dbdat-get-db dbdat)
alldat))
(use-mutex (> (alldat-api-process-request-count alldat) 25))
(db-with-db-mutex (alldat-db-with-db-mutex alldat))
(log-port (alldat-log-port alldat)))
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 log-port (alldat-api-process-request-count alldat) " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (conc "parallel-api-requests" (alldat-max-api-process-requests alldat)))
(debug:print-info 2 log-port "Parallel api request count: " (alldat-api-process-request-count alldat) " max parallel requests: " (alldat-max-api-process-requests alldat)))
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 log-port "sqlite3 issue in db:with-db, alldat=" alldat ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
;; there is no recovering at this time. exit
(exit 50))
(if use-mutex (mutex-lock! db-with-db-mutex))
(let ((res (apply proc db params)))
(if use-mutex (mutex-unlock! db-with-db-mutex))
(if dbdat (stack-push! (alldat-dbstack alldat) dbdat))
res))))
)
|
︙ | | |
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
|
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
|
-
-
+
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
|
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
(case transport-type
((http)(http-transport:launch))
(http-transport:launch))
;;((nmsg)(nmsg-transport:launch run-id))
;;((rpc) (rpc-transport:launch run-id))
(else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Get the transport
(define (server:get-transport)
(define (server:get-transport) 'http)
(if *transport-type*
*transport-type*
(let ((ttype (string->symbol
(or (args:get-arg "-transport")
(configf:lookup *configdat* "server" "transport")
"rpc"))))
(set! *transport-type* ttype)
ttype)))
;; Generate a unique signature for this server
(define (server:mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (list (current-directory)
(argv)))))))
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result)
(debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(case (server:get-transport)
((rpc) (db:obj->string (vector success/fail query-sig result)))
(db:obj->string (vector success/fail query-sig result))) ;; (send-message pubsock target send-more: #t)
((http) (db:obj->string (vector success/fail query-sig result)))
((fs) result)
(else
(debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
result)))
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area
|
︙ | | |
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
|
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
|
-
+
+
|
(if (eof-object? inl)
(case (string->symbol res)
((NOREPLY) #f)
((LOGIN_OK) #t)
(else #f))
(loop (read-line) inl))))))
;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;; NOT USED (well, ok, was referenced in rpc-transport but otherwise
;; not used).
;;
(define (server:login toppath)
(lambda (toppath)
(set! *db-last-access* (current-seconds)) ;; might not be needed.
(if (equal? *toppath* toppath)
#t
#f)))
|
︙ | | |