︙ | | | ︙ | |
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
(configdat #f)
(keys #f)
(area-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
|
>
>
|
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
|
;; 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
;;
;; 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
;;
(define (db:dashboard-open-db areas 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 (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)
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
;;
|
|
>
>
>
>
|
|
|
|
|
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
|
;; 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 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-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-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-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
|
(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: (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)
|
<
|
|
<
<
|
|
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
(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
;;
;; should always return ( dbh . path-to-db )
;;
(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: (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
|
;; (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
;;
(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
(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))
|
|
|
>
>
>
|
|
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
;; (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 (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
|
(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))
(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;")
|
|
|
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
|
(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 #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
|
)))
(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"))
(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)))
|
|
|
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
|
)))
(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 #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)))
|
︙ | | | ︙ | |