| ︙ | | |
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
-
+
|
(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path* #f)
;; (define *db-cache-path* #f)
(define *db-with-db-mutex* (make-mutex))
(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
(define *no-sync-db* #f)
;; SERVER
(define *my-client-signature* #f)
|
| ︙ | | |
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
|
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
|
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(getenv "MT_TESTSUITE_NAME")
(if (string? *toppath* )
(pathname-file *toppath*)
#f))) ;; (pathname-file (current-directory)))))
(define common:get-area-name common:get-testsuite-name)
;; WARNING: This code falls back to using the global Megatest
;; variable *toppath*
;;
(define (common:get-db-tmp-area . junk)
(if *db-cache-path*
*db-cache-path*
(if *toppath* ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")))))) ;; #t))))
(set! *db-cache-path* dbpath)
dbpath))
#f)))
(define (common:get-db-tmp-area dbstruct)
(if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path*
(dbr:dbstruct-tmpdb-path) ;; *db-cache-path*
(let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*))
(tsname (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name))))
(if toppath ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
tsname "/"
(string-translate toppath "/" ".")))))) ;; #t))))
;; (set! *db-cache-path* dbpath)
(if dbstruct (dbr:dbstruct-tmpdb-path-set! dbstruct dbpath))
dbpath))
#f))))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
|
| ︙ | | |
| ︙ | | |
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
|
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
|
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(dboard:commondat-please-update commondat)
(dboard:get-last-db-update tabdat context-key))))
;; (dboard:tabdat-last-db-update tabdat))))
(if recalc
(dboard:set-last-db-update! tabdat context-key run-update-time))
(dboard:commondat-please-update-set! commondat #f)
recalc))
;; open the area dbs, given list of areas that are "cared about"
;; areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config
;;
(define (dboard:areas-open-areas commondat tabdat areas)
(let ((areas-ht (dboard:commondat-areas commondat)))
(for-each
(lambda (area-dat)
(db:dashboard-open-db areas (car area-dat)(cdr area-dat)))
areas)))
(define (dboard:areas-update-tree tabdat runs-hash runs-header tb)
(let* ((tree-path (dboard:tabdat-tree-path tabdat))
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a runs-header "event_time"))
(time-b (db:get-value-by-header record-b runs-header "event_time")))
(< time-a time-b)))))
(changed #f)
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) ;; last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
(new-run-ids (map (lambda (run)
(db:get-value-by-header run runs-header "id"))
runs))
(for-each
(lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
(dboard:tabdat-keys tabdat)))
(run-name (db:get-value-by-header run-record runs-header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (cons "local " (append key-vals (list run-name)))))
(if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
;; (let ((existing (tree:find-node tb run-path)))
;; (if (not existing)
(begin
(hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
;; (conc rownum ":" colnum) col-name)
;; (hash-table-set! runid-to-col run-id (list colnum run-record))
;; Here we update the tests treebox and tree keys
(tree:add-node tb "Areas" run-path) ;; (append key-vals (list run-name))
;; userdata: (conc "run-id: " run-id))))
(hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
(append new-run-ids run-ids)))) ;; for-each run-id
;;(for-each
;; (lambda (run-id)
;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
;; (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
;; (dboard:tabdat-keys tabdat)))
;; (run-name (db:get-value-by-header run-record runs-header "runname"))
;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
;; (run-path (cons "local " (append key-vals (list run-name)))))
;; (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
;; ;; (let ((existing (tree:find-node tb run-path)))
;; ;; (if (not existing)
;; (begin
;; (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
;; ;; (conc rownum ":" colnum) col-name)
;; ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
;; ;; Here we update the tests treebox and tree keys
;; (tree:add-node tb "Areas" run-path) ;; (append key-vals (list run-name))
;; ;; userdata: (conc "run-id: " run-id))))
;; (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; ;; (set! colnum (+ colnum 1))
;; ))))
;; (append new-run-ids run-ids)))) ;; for-each run-id
))
(define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(key-vals (mrmt:get-key-vals run-id))
(testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
(tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
(tests-dat (dashboard:tests-ht->tests-dat tests-ht))
(tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
|
| ︙ | | |
| ︙ | | |
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
-
-
+
+
|
(tabdats (make-hash-table))
(update-mutex (make-mutex))
(updaters (make-hash-table))
(updating #f)
uidat ;; needs to move to tabdat at some time
(hide-not-hide-tabs #f)
(current-area-path #f) ;; the area of the path where the dashboard was started, if it is a megatest area
(areas (make-hash-table)) ;; area-name ==> area-path
(area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash
(areas (make-hash-table)) ;; area-name ==> dbstruct
;; (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash
)
;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
(let* ((tnum (or tab-num
(dboard:commondat-curr-tab-num commondat)
|
| ︙ | | |
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
-
-
-
+
+
+
|
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
;; (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
;; (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(if #f
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
(print "FIXME on line 350"))
(dboard:tabdat-keys-set! tabdat (mrmt:get-keys))
|
| ︙ | | |
| ︙ | | |
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
+
+
|
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
(configdat #f)
(keys #f)
(area-path #f)
(area-name #f)
(tmpdb-path #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
|
| ︙ | | |
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
|
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
|
-
+
+
+
+
+
+
-
+
-
-
+
+
-
+
|
;; return dbstruct with:
;; read-only - flag
;; tmpdb - local to this machine, all reads to this
;; mtdb - full db from mtrah
;; no-sync-db -
;; on-homehost - enable reading from other users /tmp db if files are readable
;;
;; areas is hash of areas => dbstruct, the dashboard-open-db will register the dbstruct in that hash
;; areas is hash of area_names => dbstruct, the dashboard-open-db will register the dbstruct in that hash
;;
;; NOTE: This returns the tmpdb path/handle pair.
;; NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t
;; NOTE: Longer term consider replacing db:open-db with this
;;
;; NOTE: loose ends!!
;; db:open-db -> not properly using tmpdb path
;; common:get-db-tmp-area -> using *toppath* and common:get-testsuite-area
;;
(define (db:dashboard-open-db areas area-path)
(define (db:dashboard-open-db areas area-name area-path)
;; 0. check for already existing dbstruct in areas hash, return it if found
;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct
;; 2. get homehost
;; 3. create /tmp db area (if needed)
;; 4. sync data to /tmp db (or update if exists)
;; 5. return dbstruct
(if (hash-table-exists? areas area-path)
(hash-table-ref areas area-path)
(if (hash-table-exists? areas area-name)
(hash-table-ref areas area-name)
(if (common:file-exists? (conc area-path "/megatest.config") quiet-mode: #t)
(let* ((homehost (common:minimal-get-homehost area-path))
(on-hh (common:on-host? homehost))
(mtconfig (common:simple-setup area-path)) ;; returns ( configdat toppath configfile configf-name )
(dbstruct (make-dbr:dbstruct
area-path: area-path
homehost: homehost
configdat: (car mtconfig)))
(tmpdb (db:open-db dbstruct area-path: area-path do-sync: #t)))
(hash-table-set! areas area-path dbstruct)
(hash-table-set! areas area-name dbstruct)
tmpdb)
(begin
(debug:print-info 0 *default-log-port* "attempt to open megatest.db in " area-path " but no megatest.config found.")
#f))))
;; sync all the areas listed in area-paths
;;
|
| ︙ | | |
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
-
-
-
+
+
-
-
-
+
|
(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
(let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
(let ((newdb (db:open-megatest-db path: (dbr:dbstruct-area-path dbstruct)))) ;; (db:dbfile-path))))
;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
newdb)
(stack-pop! (dbr:dbstruct-dbstack dbstruct)))
(db:open-db dbstruct)))
;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
|
| ︙ | | |
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
|
-
+
-
-
+
+
+
+
+
|
;; (dbr:dbstruct-inuse-set! dbstruct #t)
;; (dbr:dbstruct-olddb-set! dbstruct olddb)
;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's?
;; (db:sync-tables db:sync-tests-only *megatest-db* db)
;; db))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
;; ALWAYS returns ( dbh . path-to-db )
(define (db:open-db dbstruct #!key (area-path #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* ((toppath (or area-path (dbr:dbstruct-area-path dbstruct) *toppath*))
(dbpath (db:dbfile-path )) ;; path to tmp db area
(let* ((toppath (or area-path
(dbr:dbstruct-area-path dbstruct)
*toppath*))
(dbpath (or (dbr:dbstruct-tmpdb-path dbstruct)
(db:dbfile-path dbstruct))) ;; 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")))
(mtdb (db:open-megatest-db path: area-path))
(mtdbpath (db:dbdat-get-path mtdb))
|
| ︙ | | |
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
|
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
|
-
+
|
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
(define (db:open-no-sync-db)
(let* ((dbpath (db:dbfile-path))
(let* ((dbpath (db:dbfile-path #f))
(dbname (conc dbpath "/no-sync.db"))
(db-exists (common:file-exists? dbname))
(db (sqlite3:open-database dbname)))
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(if (not db-exists)
(begin
(sqlite3:execute db "PRAGMA synchronous = 0;")
|
| ︙ | | |
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
|
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
|
-
+
|
)))
(debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(vector header res)))
;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
;;
(define (db:get-changed-run-ids since-time)
(let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
(let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir"))
(alldbs (glob (conc dbdir "/[0-9]*.db")))
(changed (filter (lambda (dbfile)
(> (file-modification-time dbfile) since-time))
alldbs)))
(delete-duplicates
(map (lambda (dbfile)
(let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))
|
| ︙ | | |