| ︙ | | | ︙ | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))
(module dbmod
*
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))
(module dbmod
(
;; for debug, can be commented out in production
dbmod:safely-open-db
dbmod:with-db
dbmod:open-db
;; used elsewhere, keep
dbmod:db-to-db-sync
db:test-get-event_time
db:test-get-item-path
db:test-get-testname
db:get-value-by-header
db:get-subdb
db:multi-db-sync
dbmod:open-dbmoddb
dbmod:run-id->dbfname
db:roll-up-rules
db:get-all-state-status-counts-for-test
db:test-set-state-status-db
db:general-call
db:cache-for-read-only
db:convert-test-itempath
db:test-data-rollup
db:keep-trying-until-true
db:get-test-info-by-id
db:with-db
db:get-test-id
db:get-test-info
dbmod:print-db-stats
db:get-keys
db:open-no-sync-db
db:add-stats
;; dbr:counts record accessors
dbr:counts->alist
db:add-var
db:archive-register-block-name
db:archive-register-disk
db:create-all-triggers
db:csv->test-data
db:dec-var
db:del-var
db:delete-old-deleted-test-records
db:delete-run
db:delete-steps-for-test!
db:delete-test-records
db:drop-all-triggers
db:get-all-run-ids
db:get-all-runids
db:get-changed-record-ids
db:get-changed-record-run-ids
db:get-changed-record-test-ids
db:get-count-tests-running
db:get-count-tests-running-for-run-id
db:get-count-tests-running-for-testname
db:get-count-tests-running-in-jobgroup
db:get-data-info-by-id
db:get-key-val-pairs
db:get-key-vals
db:get-latest-host-load
db:get-main-run-stats
db:get-matching-previous-test-run-records
db:get-not-completed-cnt
db:get-num-runs
db:get-prereqs-not-met
db:get-prev-run-ids
db:get-raw-run-stats
db:get-run-ids-matching-target
db:get-run-info
db:get-run-name-from-id
db:get-run-record-ids
db:get-run-state
db:get-run-state-status
db:get-run-stats
db:get-run-status
db:get-run-times
db:get-runs
db:get-runs-by-patt
db:get-runs-cnt-by-patt
db:get-steps-data
db:get-steps-for-test
db:get-steps-info-by-id
db:get-target
db:get-targets
db:get-test-state-status-by-id
db:get-test-times
db:get-testinfo-state-status
db:get-tests-for-run
db:get-tests-for-run-mindata
db:get-tests-for-run-state-status
db:get-tests-tags
db:get-toplevels-and-incompletes
db:get-var
db:have-incompletes?
db:inc-var
db:initialize-main-db
db:insert-run
db:insert-test
db:lock/unlock-run
db:login
db:read-test-data
db:read-test-data-varpatt
db:register-run
db:set-run-state-status
db:set-run-status
db:set-state-status-and-roll-up-run
db:set-var
db:simple-get-runs
db:test-get-archive-block-info
db:test-get-logfile-info
db:test-get-paths-matching-keynames-target-new
db:test-get-records-for-index-file
db:test-get-rundir-from-test-id
db:test-get-top-process-pid
db:test-set-archive-block-id
db:test-set-state-status
db:test-set-top-process-pid
db:test-toplevel-num-items
db:testmeta-add-record
db:testmeta-get-record
db:testmeta-update-field
db:teststep-set-status!
db:top-test-set-per-pf-counts
db:update-run-event_time
db:update-run-stats
db:update-tesdata-on-repilcate-db
tasks:add
tasks:find-task-queue-records
tasks:get-last
tasks:set-state-given-param-key
*db-stats*
dbmod:nfs-get-dbstruct
*db-stats-mutex*
db:get-header
db:get-rows
db:get-changed-run-ids
db:set-sync
db:setup
db:get-access-mode
db:test-record-fields
db:logpro-dat->csv
std-exit-procedure
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
data-structures
|
| ︙ | | | ︙ | |
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
commonmod
configfmod
dbfile
debugprint
mtmod
)
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
|
|
|
|
|
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
|
commonmod
configfmod
dbfile
debugprint
mtmod
)
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
|
| ︙ | | | ︙ | |
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
|
(begin
(sync-proc last-update)
;; MOVE THIS CALL TO INSIDE THE sync-proc CALL
(dbr:dbstruct-last-update-set! dbstruct curr-secs)
)))
(assert (sqlite3:database? dbh) "FATAL: bad db handle in dbmod:with-db")
(if use-mutex (mutex-lock! *db-with-db-mutex*))
(let* ((res (let loop ((count 3))
(condition-case
(apply proc dbdat dbh params)
(exn (busy)
(if (> count 0)
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.")
(thread-sleep! 1)
(loop (- count 1)))
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.")
(exit 1))))
(exn ()
(dbfile:print-err exn "ERROR: dbmod:with-db: Unknown error with database for run-id "run-id", message: "
((condition-property-accessor 'exn 'message) exn))
(exit 2))))))
(if use-mutex (mutex-unlock! *db-with-db-mutex*))
res)))
(define (db:with-db dbstruct run-id w/r proc . params)
(dbmod:with-db dbstruct run-id w/r proc params))
;;
(define (dbmod:open-cachedb-db init-proc dbfullname)
|
|
|
|
|
>
>
>
|
|
|
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
|
(begin
(sync-proc last-update)
;; MOVE THIS CALL TO INSIDE THE sync-proc CALL
(dbr:dbstruct-last-update-set! dbstruct curr-secs)
)))
(assert (sqlite3:database? dbh) "FATAL: bad db handle in dbmod:with-db")
;; (if use-mutex (mutex-lock! *db-with-db-mutex*)) ;; this mutex was causing deadlock. Found in fullrun test.
(let* ((res (let loop ((count 10))
(condition-case
(apply proc dbdat dbh params)
(exn (sqlite3) ;; was 'busy', but never got hit
(if (> count 0)
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.")
(thread-sleep! 1)
(loop (- count 1)))
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up. params: "params)
(exit 1))))
(exn (locked)
(dbfile:print-err exn "ERROR: dbmod:with-db: database locked for run-id "run-id", params "params", message: "
((condition-property-accessor 'exn 'message) exn)))
(exn ()
(dbfile:print-err exn "ERROR: dbmod:with-db: Unknown error with database for run-id "run-id", params "params", message: "
((condition-property-accessor 'exn 'message) exn))
(exit 2))))))
;; (if use-mutex (mutex-unlock! *db-with-db-mutex*))
res)))
(define (db:with-db dbstruct run-id w/r proc . params)
(dbmod:with-db dbstruct run-id w/r proc params))
;;
(define (dbmod:open-cachedb-db init-proc dbfullname)
|
| ︙ | | | ︙ | |
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
(debug:print 0 *default-log-port* "Unknown dbfile:sync-method setting: "
(dbfile:sync-method)))))
(else
(debug:print 0 *default-log-port* "Unknown dbfile:cache-method setting: "
(dbfile:cache-method))
#f)))
(define (dbmod:safely-open-db dbfullname init-proc write-access)
(dbfile:with-simple-file-lock
(conc dbfullname".lock")
(lambda ()
(let* ((dbexists (file-exists? dbfullname))
(db (sqlite3:open-database dbfullname))
(handler (sqlite3:make-busy-timeout 136000)))
|
>
>
>
|
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
|
(debug:print 0 *default-log-port* "Unknown dbfile:sync-method setting: "
(dbfile:sync-method)))))
(else
(debug:print 0 *default-log-port* "Unknown dbfile:cache-method setting: "
(dbfile:cache-method))
#f)))
;;
;; converge this with dbfile:cautious-open-database
;;
(define (dbmod:safely-open-db dbfullname init-proc write-access)
(dbfile:with-simple-file-lock
(conc dbfullname".lock")
(lambda ()
(let* ((dbexists (file-exists? dbfullname))
(db (sqlite3:open-database dbfullname))
(handler (sqlite3:make-busy-timeout 136000)))
|
| ︙ | | | ︙ | |
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
|
;; (define (db:with-db dbstruct run-id r/w proc . params)
;; (case (rmt:transport-mode)
;; ((http)(dbfile:with-db dbstruct run-id r/w proc params))
;; ((tcp) (dbmod:with-db dbstruct run-id r/w proc params))
;; ((nfs) (dbmod:with-db dbstruct run-id r/w proc params))
;; (else (assert #f "FATAL: db:with-db called with non-existant transport mode"))))
;;======================================================================
;; hash of hashs
;;======================================================================
(define (db:hoh-set! dat key1 key2 val)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(if subhash
(hash-table-set! subhash key2 val)
(begin
(hash-table-set! dat key1 (make-hash-table))
(db:hoh-set! dat key1 key2 val)))))
(define (db:hoh-get dat key1 key2)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(and subhash
(hash-table-ref/default subhash key2 #f))))
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
|
;; (define (db:with-db dbstruct run-id r/w proc . params)
;; (case (rmt:transport-mode)
;; ((http)(dbfile:with-db dbstruct run-id r/w proc params))
;; ((tcp) (dbmod:with-db dbstruct run-id r/w proc params))
;; ((nfs) (dbmod:with-db dbstruct run-id r/w proc params))
;; (else (assert #f "FATAL: db:with-db called with non-existant transport mode"))))
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
(define (db:general-sqlite-error-dump exn stmt . params)
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
|
| ︙ | | | ︙ | |
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
|
(begin
(db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
(hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
(debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
dbfiles))
data-synced))
;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
(let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
(res '()))
(for-each
(lambda (subdb)
(let* ((mtdb (dbr:subdb-mtdbdat subdb))
(tmpdb (db:get-subdb dbstruct run-id))
(refndb (dbr:subdb-refndb subdb))
(newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
;; BUG: verify this is really needed
(dbfile:add-dbdat dbstruct run-id tmpdb)
(set! res (cons newres res))))
subdbs)
res))
;;;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
;;
;; NB// no-sync-db is the db handle, not a flag!
;;
(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
(let* ((start-time (current-seconds))
(last-full-update (if no-sync-db
(db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
0))
(full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
(last-update (if full-sync-needed
0
(if no-sync-db
(db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
(sync-needed (> (- start-time last-update) 6))
(res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
full-sync-needed)
(begin
(if no-sync-db
(begin
(if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
(db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
(db:tmp->megatest.db-sync dbstruct last-update))
0))
(sync-time (- (current-seconds) start-time)))
(debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(if (common:low-noise-print 30 "sync new to old")
(if sync-needed
(debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
res))
(define (db:initialize-main-db db #!key (launch-setup #f))
(when (not *configinfo*)
(if launch-setup
(launch-setup) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(assert #f "db:initialize-main-db called and needs launch:setup but was not given it")))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
|
(begin
(db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
(hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
(debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
dbfiles))
data-synced))
;; ;; Sync all changed db's
;; ;;
;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update)
;; (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
;; (res '()))
;; (for-each
;; (lambda (subdb)
;; (let* ((mtdb (dbr:subdb-mtdbdat subdb))
;; (tmpdb (db:get-subdb dbstruct run-id))
;; (refndb (dbr:subdb-refndb subdb))
;; (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
;; ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
;; ;; BUG: verify this is really needed
;; (dbfile:add-dbdat dbstruct run-id tmpdb)
;; (set! res (cons newres res))))
;; subdbs)
;; res))
;;;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
;;
;; NB// no-sync-db is the db handle, not a flag!
;;
;; (define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
;; (let* ((start-time (current-seconds))
;; (last-full-update (if no-sync-db
;; (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
;; 0))
;; (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
;; (last-update (if full-sync-needed
;; 0
;; (if no-sync-db
;; (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
;; 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
;; (sync-needed (> (- start-time last-update) 6))
;; (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
;; full-sync-needed)
;; (begin
;; (if no-sync-db
;; (begin
;; (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
;; (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
;; (db:tmp->megatest.db-sync dbstruct run-id last-update))
;; 0))
;; (sync-time (- (current-seconds) start-time)))
;; (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
;; (if (common:low-noise-print 30 "sync new to old")
;; (if sync-needed
;; (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
;; (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
;; res))
(define (db:initialize-main-db db #!key (launch-setup #f))
(when (not *configinfo*)
(if launch-setup
(launch-setup) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(assert #f "db:initialize-main-db called and needs launch:setup but was not given it")))
|
| ︙ | | | ︙ | |
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
|
dbstruct
run-id
#t
(lambda (dbdat db)
(delproc db)))
(if (and (file-exists? mtdbfile)
(file-write-access? mtdbfile))
(let* ((db (sqlite3:open-database mtdbfile)))
(delproc db)
(sqlite3:finalize! db)))))
;; ;; speed up for common cases with a little logic
;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
;; NOTE: run-id is not used
|
|
>
>
|
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
|
dbstruct
run-id
#t
(lambda (dbdat db)
(delproc db)))
(if (and (file-exists? mtdbfile)
(file-write-access? mtdbfile))
(let* ((db (sqlite3:open-database mtdbfile))
(handler (sqlite3:make-busy-timeout 136000)))
(sqlite3:set-busy-handler! db handler)
(delproc db)
(sqlite3:finalize! db)))))
;; ;; speed up for common cases with a little logic
;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
;; NOTE: run-id is not used
|
| ︙ | | | ︙ | |