︙ | | | ︙ | |
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
(define (db:setup do-sync)
(assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
(dbfile:setup do-sync *toppath*))
;; looks up subdb and returns it, if not found then set up
;; and then return it.
;;
(define (db:get-db dbstruct run-id)
(let* ((res (dbfile:get-subdb dbstruct run-id)))
(if res
res
(let* ((newsubdb (make-dbr:subdb)))
(dbfile:set-subdb dbstruct run-id newsubdb)
(db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
newsubdb))))
|
|
|
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
(define (db:setup do-sync)
(assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
(dbfile:setup do-sync *toppath*))
;; looks up subdb and returns it, if not found then set up
;; and then return it.
;;
#;(define (db:get-db dbstruct run-id)
(let* ((res (dbfile:get-subdb dbstruct run-id)))
(if res
res
(let* ((newsubdb (make-dbr:subdb)))
(dbfile:set-subdb dbstruct run-id newsubdb)
(db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
newsubdb))))
|
︙ | | | ︙ | |
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
;; (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 ;; this stuff just allows us to call with a db handle directly
(db:get-db dbstruct run-id)
#f))
(db (if have-struct ;; this stuff just allows us to call with a db handle directly
(dbr:dbdat-dbh dbdat)
dbstruct))
(fname (if dbdat
(dbr:dbdat-dbfile dbdat)
"nofilenameavailable"))
|
|
|
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
;; (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 ;; this stuff just allows us to call with a db handle directly
(db:get-subdb dbstruct run-id)
#f))
(db (if have-struct ;; this stuff just allows us to call with a db handle directly
(dbr:dbdat-dbh dbdat)
dbstruct))
(fname (if dbdat
(dbr:dbdat-dbfile dbdat)
"nofilenameavailable"))
|
︙ | | | ︙ | |
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))
;;
(define (db:lock-create-open fname initproc)
(let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
(raw-fname (pathname-file fname))
(dir-writable (file-write-access? parent-dir))
(file-exists (common:file-exists? fname))
(file-write (if file-exists
(file-write-access? fname)
dir-writable )))
|
|
|
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))
;;
#;(define (db:lock-create-open fname initproc)
(let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
(raw-fname (pathname-file fname))
(dir-writable (file-write-access? parent-dir))
(file-exists (common:file-exists? fname))
(file-write (if file-exists
(file-write-access? fname)
dir-writable )))
|
︙ | | | ︙ | |
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
|
(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 run-id #!key (areapath #f)(do-sync #t))
(let* ((subdb (dbfile:get-subdb dbstruct run-id))
(tmpdb-stack (dbr:subdb-dbstack subdb)))
(if (stack? tmpdb-stack)
(db:get-db tmpdb-stack run-id) ;; 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 (db:dbfile-path)) ;; path to tmp db area
(dbname (db:run-id->dbname run-id))
(dbexists (common:file-exists? dbpath))
(mtdbfname (conc *toppath* "/"dbname))
(mtdbexists (common:file-exists? mtdbfname))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f))
|
|
|
|
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
|
(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 run-id #!key (areapath #f)(do-sync #t))
(let* ((subdb (dbfile:get-subdb dbstruct run-id))
(tmpdb-stack (dbr:subdb-dbstack subdb)))
(if (stack? tmpdb-stack)
(db:get-subdb tmpdb-stack run-id) ;; 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 (db:dbfile-path)) ;; path to tmp db area
(dbname (db:run-id->dbname run-id))
(dbexists (common:file-exists? dbpath))
(mtdbfname (conc *toppath* "/"dbname))
(mtdbexists (common:file-exists? mtdbfname))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f))
|
︙ | | | ︙ | |
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
|
;; (cons db dbpath)))
(make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
(let* ((subdb (dbfile:get-subdb dbstruct run-id))
(tmpdb (db:get-db dbstruct run-id))
(mtdb (dbr:subdb-mtdb subdb))
(refndb (dbr:subdb-refndb subdb))
(start-t (current-seconds)))
(debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
(mutex-lock! *db-multi-sync-mutex*)
(let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
(mutex-unlock! *db-multi-sync-mutex*)
|
|
|
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
|
;; (cons db dbpath)))
(make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
(let* ((subdb (dbfile:get-subdb dbstruct run-id))
(tmpdb (db:get-subdb dbstruct run-id))
(mtdb (dbr:subdb-mtdb subdb))
(refndb (dbr:subdb-refndb subdb))
(start-t (current-seconds)))
(debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
(mutex-lock! *db-multi-sync-mutex*)
(let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
(mutex-unlock! *db-multi-sync-mutex*)
|
︙ | | | ︙ | |
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
|
(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* ((dbname (db:run-id->dbname run-id))
(mtdb (dbr:subdb-mtdb subdb))
(tmpdb (db:get-db dbstruct run-id))
(refndb (dbr:subdb-refndb subdb))
(newres (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
(stack-push! (dbr:subdb-dbstack subdb) tmpdb)
(set! res (cons newres res))))
subdbs)
res))
|
|
|
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
|
(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* ((dbname (db:run-id->dbname run-id))
(mtdb (dbr:subdb-mtdb subdb))
(tmpdb (db:get-subdb dbstruct run-id))
(refndb (dbr:subdb-refndb subdb))
(newres (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
(stack-push! (dbr:subdb-dbstack subdb) tmpdb)
(set! res (cons newres res))))
subdbs)
res))
|
︙ | | | ︙ | |
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
|
;;======================================================================
;; dneeded is minimum space needed, scan for existing archives that
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
(let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res '())
(blocks '())) ;; a block is an archive chunck that can be added too if there is space
(sqlite3:for-each-row
(lambda (id archive-disk-id disk-path last-du last-du-time)
(set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
db
|
|
|
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
|
;;======================================================================
;; dneeded is minimum space needed, scan for existing archives that
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
(let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res '())
(blocks '())) ;; a block is an archive chunck that can be added too if there is space
(sqlite3:for-each-row
(lambda (id archive-disk-id disk-path last-du last-du-time)
(set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
db
|
︙ | | | ︙ | |
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
|
(stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
blocks))
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
(let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res #f))
(sqlite3:for-each-row
(lambda (id)
(set! res id))
db
"SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
|
|
|
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
|
(stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
blocks))
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
(let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res #f))
(sqlite3:for-each-row
(lambda (id)
(set! res id))
db
"SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
|
︙ | | | ︙ | |
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
|
(db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
(let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res #f))
;; first look to see if this path is already registered
(sqlite3:for-each-row
(lambda (id)
(set! res id))
db
|
|
|
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
|
(db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
(let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res #f))
;; first look to see if this path is already registered
(sqlite3:for-each-row
(lambda (id)
(set! res id))
db
|
︙ | | | ︙ | |
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
|
(set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
db
"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
archive-block-id)
res))))
;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
;; (db (dbr:dbdat-dbh dbdat))
;; (res '())
;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
;; (sqlite3:for-each-row #f)
;;======================================================================
;; L O G G I N G D B
|
|
|
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
|
(set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
db
"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
archive-block-id)
res))))
;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;; (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
;; (db (dbr:dbdat-dbh dbdat))
;; (res '())
;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
;; (sqlite3:for-each-row #f)
;;======================================================================
;; L O G G I N G D B
|
︙ | | | ︙ | |
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
|
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-db dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; (db:general-call dbdat 'set-test-start-time (list test-id)))
;; ;; (if msg
;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;; ;; process the test_data table
|
|
|
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
|
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-subdb dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; (db:general-call dbdat 'set-test-start-time (list test-id)))
;; ;; (if msg
;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;; ;; process the test_data table
|
︙ | | | ︙ | |
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
|
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
(assert #f "FATAL: call to db:extract-ods-file which is not ported yet.")
(let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
(keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
(numkeys (length keypatt-alist))
(test-ids '())
(dbdat (db:get-db dbstruct))
(db (dbr:dbdat-dbh dbdat))
(windows (and pathmod (substring-index "\\" pathmod)))
(tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
(runsheader (append (list "Run Id" "Runname") ; 0 1
(map car keypatt-alist) ; + N = length keypatt-alist
(list "Testname" ; 2
"Item Path" ; 3
|
|
|
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
|
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
(assert #f "FATAL: call to db:extract-ods-file which is not ported yet.")
(let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
(keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
(numkeys (length keypatt-alist))
(test-ids '())
(dbdat (db:get-subdb dbstruct))
(db (dbr:dbdat-dbh dbdat))
(windows (and pathmod (substring-index "\\" pathmod)))
(tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
(runsheader (append (list "Run Id" "Runname") ; 0 1
(map car keypatt-alist) ; + N = length keypatt-alist
(list "Testname" ; 2
"Item Path" ; 3
|
︙ | | | ︙ | |