Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -22,17 +22,24 @@
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm margs.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
- ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
+ http-transport.scm tdb.scm client.scm mt.scm \
+ ezsteps.scm lock-queue.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = dbmod.scm
+MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm
+
+all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
+
+# dbmod.import.o is just a hack here
+mofiles/dbfile.o : mofiles/debugprint.o dbmod.import.o
+mofiles/debugprint.o : mofiles/mtargs.o
+
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
@@ -78,12 +85,10 @@
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")
PNGFILES = $(shell cd docs/manual;ls *png)
-# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
-all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) megatest-version.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@@ -150,11 +155,13 @@
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
-# common.o : mofiles/commonmod.o megatest-fossil-hash.scm
+mofiles/commonmod.o : megatest-fossil-hash.scm
+common.o : mofiles/commonmod.o
+
# mofiles/dbmod.o : mofiles/configfmod.o
# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
tests.o db.o launch.o runs.o dashboard-tests.o \
@@ -162,21 +169,23 @@
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
-db.o api.o : mofiles/dbmod.o
+db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm megatest-version.scm
-rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
+rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
common_records.scm : altdb.scm
+
+mofiles/dbfile.o : mofiles/commonmod.o
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
vg.o dashboard.o : vg_records.scm megatest-version.scm
@@ -293,10 +302,19 @@
chmod a+x $@
$(PREFIX)/bin/mtrunner : utils/mtrunner
$(INSTALL) $< $@
chmod a+x $@
+
+$(PREFIX)/bin/mt-old-to-new.sh : utils/mt-old-to-new.sh
+ $(INSTALL) $< $@
+ chmod a+x $@
+
+$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh
+ $(INSTALL) $< $@
+ chmod a+x $@
+
deploytarg/nbfake : utils/nbfake
$(INSTALL) $< $@
chmod a+x $@
@@ -339,10 +357,11 @@
install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
$(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
$(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
$(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
+ $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
$(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
@@ -455,12 +474,12 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -24,13 +24,15 @@
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
+(declare (uses dbfile))
(declare (uses tasks))
(import dbmod)
+(import dbfile)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
@@ -144,21 +146,26 @@
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
- (handle-exceptions
- exn
- (let ((call-chain (get-call-chain)))
- (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
+ (db:open-no-sync-db) ;; sets *no-sync-db*
+;; (handle-exceptions
+;; exn
+;; (let ((call-chain (get-call-chain)))
+;; (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
+;; (print-call-chain (current-error-port))
+;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
+ (if (> *api-process-request-count* 200)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Over 200 threads, overload, taking a five second nap.")
+ (thread-sleep! 5))) ;; take a nap
(cond
((not (vector? dat)) ;; it is an error to not receive a vector
(vector #f (vector #f "remote must be called with a vector")))
- ((> *api-process-request-count* 20) ;; 20)
+ #;((> *api-process-request-count* 200) ;; 20)
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
(set! *server-overloaded* #t)
(vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
(else
(let* ((cmd-in (vector-ref dat 0))
@@ -228,19 +235,19 @@
((del-var) (apply db:del-var dbstruct params))
((add-var) (apply db:add-var dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
- ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
+ ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
;; TEST DATA
((test-data-rollup) (apply db:test-data-rollup dbstruct params))
((csv->test-data) (apply db:csv->test-data dbstruct params))
;; MISC
((sync-inmem->db) (let ((run-id (car params)))
- (db:sync-touched dbstruct run-id force-sync: #t)))
+ (db:sync-touched dbstruct run-id db:initialize-main-db force-sync: #t)))
((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
((create-all-triggers) (db:create-all-triggers dbstruct))
((drop-all-triggers) (db:drop-all-triggers dbstruct))
;; TESTMETA
@@ -342,11 +349,11 @@
((have-incompletes?) (apply db:have-incompletes? dbstruct params))
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
- (db:general-call dbstruct stmtname realparams)))
+ (db:general-call dbstruct run-id stmtname realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
@@ -372,11 +379,11 @@
(vector #f res))
(begin
#;(common:telemetry-log (conc "api-out:"(->string cmd))
payload: `((params . ,params)
(ok-res . #f)))
- (vector #t res))))))))
+ (vector #t res))))))) ;; )
;; http-server send-response
;; api:process-request
;; db:*
;;
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -397,11 +397,11 @@
(bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
(debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
(run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
(sleep 2)
(db:multi-db-sync
- (db:setup #f)
+ (db:setup #t) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
'killservers
;'dejunk
;'adj-testids
'old2new
)
ADDED attic/filedb.scm
Index: attic/filedb.scm
==================================================================
--- /dev/null
+++ attic/filedb.scm
@@ -0,0 +1,255 @@
+;; Copyright 2006-2011, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+
+;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
+(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit filedb))
+
+(include "fdb_records.scm")
+;; (include "settings.scm")
+
+(define (filedb:open-db dbpath)
+ (let* ((fdb (make-filedb:fdb))
+ (dbexists (common:file-exists? dbpath))
+ (db (sqlite3:open-database dbpath)))
+ (filedb:fdb-set-db! fdb db)
+ (filedb:fdb-set-dbpath! fdb dbpath)
+ (filedb:fdb-set-pathcache! fdb (make-hash-table))
+ (filedb:fdb-set-idcache! fdb (make-hash-table))
+ (filedb:fdb-set-partcache! fdb (make-hash-table))
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "PRAGMA synchronous = OFF;")
+ (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
+ (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
+ ;; NB// We store a useful subset of file attributes but do not attempt to store all
+ (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
+ path TEXT,
+ parent_id INTEGER,
+ mode INTEGER DEFAULT -1,
+ uid INTEGER DEFAULT -1,
+ gid INTEGER DEFAULT -1,
+ size INTEGER DEFAULT -1,
+ mtime INTEGER DEFAULT -1);")
+ (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
+ (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
+ ;; close the sqlite3 db and open it as needed
+ (filedb:finalize-db! fdb)
+ (filedb:fdb-set-db! fdb #f)
+ fdb))
+
+(define (filedb:reopen-db fdb)
+ (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
+ (filedb:fdb-set-db! fdb db)
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
+
+(define (filedb:finalize-db! fdb)
+ (sqlite3:finalize! (filedb:fdb-get-db fdb)))
+
+(define (filedb:get-current-time-string)
+ (string-chomp (time->string (seconds->local-time (current-seconds)))))
+
+(define (filedb:get-base-id db path)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:get-path-id db path parent)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path parent)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:add-base db path)
+ (let ((existing (filedb:get-base-id db path)))
+ (if existing #f
+ (begin
+ (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
+
+;; index value field notes
+;; 0 inode number st_ino
+;; 1 mode st_mode bitfield combining file permissions and file type
+;; 2 number of hard links st_nlink
+;; 3 UID of owner st_uid as with file-owner
+;; 4 GID of owner st_gid
+;; 5 size st_size as with file-size
+;; 6 access time st_atime as with file-access-time
+;; 7 change time st_ctime as with file-change-time
+;; 8 modification time st_mtime as with file-modification-time
+;; 9 parent device ID st_dev ID of device on which this file resides
+;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
+;; 11 block size st_blksize
+;; 12 number of blocks allocated st_blocks
+
+(define (filedb:add-path-stat db path parent statinfo)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
+ (sqlite3:execute stmt
+ path
+ parent
+ (vector-ref statinfo 1) ;; mode
+ (vector-ref statinfo 3) ;; uid
+ (vector-ref statinfo 4) ;; gid
+ (vector-ref statinfo 5) ;; size
+ (vector-ref statinfo 8) ;; mtime
+ )
+ (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
+
+(define (filedb:add-path db path parent)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
+ (sqlite3:execute stmt path parent)
+ (sqlite3:finalize! stmt)))
+
+(define (filedb:register-path fdb path #!key (save-stat #f))
+ (let* ((db (filedb:fdb-get-db fdb))
+ (pathcache (filedb:fdb-get-pathcache fdb))
+ (stat (if save-stat (file-stat path #t)))
+ (id (hash-table-ref/default pathcache path #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if id id
+ (let ((plist (string-split path "/")))
+ (let loop ((head (car plist))
+ (tail (cdr plist))
+ (parent 0))
+ (let ((id (filedb:get-path-id db head parent))
+ (done (null? tail)))
+ (if id ;; we'll have a id if the path is already registered
+ (if done
+ (begin
+ (hash-table-set! pathcache path id)
+ id) ;; return the last path id for a result
+ (loop (car tail)(cdr tail) id))
+ (begin ;; add the path and then repeat the loop with the same data
+ (if save-stat
+ (filedb:add-path-stat db head parent stat)
+ (filedb:add-path db head parent))
+ (loop head tail parent)))))))))
+
+(define (filedb:update-recursively fdb path #!key (save-stat #f))
+ (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
+ (print "processed 0 files...")
+ (let loop ((l (read-line p))
+ (lc 0)) ;; line count
+ (if (eof-object? l)
+ (begin
+ (print " " lc " files")
+ (close-input-port p))
+ (begin
+ (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
+ (if (= (modulo lc 100) 0)
+ (print " " lc " files"))
+ (loop (read-line p)(+ lc 1)))))))
+
+(define (filedb:update fdb path #!key (save-stat #f))
+ ;; first get the realpath and add it to the bases table
+ (let ((real-path path) ;; (filedb:get-real-path path))
+ (db (filedb:fdb-get-db fdb)))
+ (filedb:add-base db real-path)
+ (filedb:update-recursively fdb path save-stat: save-stat)))
+
+;; not used and broken
+;;
+(define (filedb:get-real-path path)
+ (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
+ (pth (read-line p)))
+ (if (eof-object? pth) path
+ (begin
+ (close-input-port p)
+ pth))))
+
+(define (filedb:drop-base fdb path)
+ (print "Sorry, I don't do anything yet"))
+
+(define (filedb:find-all fdb pattern action)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
+ (result '()))
+ (sqlite3:for-each-row
+ (lambda (num)
+ (action num)
+ (set! result (cons num result))) stmt pattern)
+ (sqlite3:finalize! stmt)
+ result))
+
+(define (filedb:get-path-record fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (partcache (filedb:fdb-get-partcache fdb))
+ (dat (hash-table-ref/default partcache id #f)))
+ (if dat dat
+ (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
+ (result #f))
+ (sqlite3:for-each-row
+ (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
+ (hash-table-set! partcache id result)
+ (sqlite3:finalize! stmt)
+ result))))
+
+(define (filedb:get-children fdb parent-id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
+ parent-id)
+ res))
+
+;; retrieve all that have children and those without
+;; children that match patt
+(define (filedb:get-children-patt fdb parent-id search-patt)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ ;; first get the children that have no children
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
+ (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
+ parent-id search-patt)
+ res))
+
+(define (filedb:get-path fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (idcache (filedb:fdb-get-idcache fdb))
+ (path (hash-table-ref/default idcache id #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if path path
+ (let loop ((curr-id id)
+ (path ""))
+ (let ((path-record (filedb:get-path-record fdb curr-id)))
+ (if (not path-record) #f ;; this id has no path
+ (let* ((parent-id (list-ref path-record 1))
+ (pname (list-ref path-record 0))
+ (newpath (string-append "/" pname path)))
+ (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
+ (begin
+ (hash-table-set! idcache id newpath)
+ newpath)
+ (loop parent-id newpath)))))))))
+
+(define (filedb:search db pattern)
+ (let ((action (lambda (id)(print (filedb:get-path db id)))))
+ (filedb:find-all db pattern action)))
+
ADDED attic/ftail.scm
Index: attic/ftail.scm
==================================================================
--- /dev/null
+++ attic/ftail.scm
@@ -0,0 +1,108 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+ (
+ open-tail-db
+ tail-write
+ tail-get-fid
+ file-tail
+ )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+ (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
+ (dbpath (conc basedir "/megatest_logs.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ))
+ db))
+
+(define (tail-write db fid lines)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+ lines))))
+
+(define (tail-get-fid db fname)
+ (let ((fid (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+ (if fid
+ fid
+ (begin
+ (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+ (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+ (let* ((inp (open-input-file fname))
+ (db (or db-in (open-tail-db)))
+ (fid (tail-get-fid db fname)))
+ (let loop ((inl (read-line inp))
+ (lines '())
+ (lastwr (current-seconds)))
+ (if (eof-object? inl)
+ (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+ (if timed-out (tail-write db fid (reverse lines)))
+ (sleep 1)
+ (if timed-out
+ (loop (read-line inp) '() (current-seconds))
+ (loop (read-line inp) lines lastwr)))
+ (let* ((savelines (> (length lines) 19)))
+ ;; (print inl)
+ (if savelines (tail-write db fid (reverse lines)))
+ (loop (read-line inp)
+ (if savelines
+ '()
+ (cons inl lines))
+ (if savelines
+ (current-seconds)
+ lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+ (if (> offset 0)
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+ (reverse ;; get N from the end
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)
ADDED attic/sdb.scm
Index: attic/sdb.scm
==================================================================
--- /dev/null
+++ attic/sdb.scm
@@ -0,0 +1,116 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+;;======================================================================
+;; Simple persistant strings lookup table. Keep out of the main db
+;; so writes/reads don't slow down central access.
+;;======================================================================
+
+(require-extension (srfi 18) extras)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
+(import (prefix sqlite3 sqlite3:))
+(import (prefix base64 base64:))
+
+(declare (unit sdb))
+
+;;
+(define (sdb:open fname)
+ (let* ((dbpath (pathname-directory fname))
+ (dbexists (let ((fe (common:file-exists? fname)))
+ (if fe
+ fe
+ (begin
+ (create-directory dbpath #t)
+ #f))))
+ (sdb (sqlite3:open-database fname))
+ (handler (make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! sdb handler)
+ (if (not dbexists)
+ (sdb:initialize sdb))
+ (sqlite3:execute sdb "PRAGMA synchronous = 1;")
+ sdb))
+
+(define (sdb:initialize sdb)
+ (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
+ (id INTEGER PRIMARY KEY,
+ str TEXT,
+ CONSTRAINT str UNIQUE (str));")
+ (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))
+
+;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))
+
+(define (sdb:register-string sdb str)
+ (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
+
+(define (sdb:string->id sdb str-cache str)
+ (let ((id (hash-table-ref/default str-cache str #f)))
+ (if (not id)
+ (sqlite3:for-each-row
+ (lambda (sid)
+ (set! id sid)
+ (hash-table-set! str-cache str id))
+ sdb
+ "SELECT id FROM strs WHERE str=?;" str))
+ id))
+
+(define (sdb:id->string sdb id-cache id)
+ (let ((str (hash-table-ref/default id-cache id #f)))
+ (if (not str)
+ (sqlite3:for-each-row
+ (lambda (istr)
+ (set! str istr)
+ (hash-table-set! id-cache id str))
+ sdb
+ "SELECT str FROM strs WHERE id=?;" id))
+ str))
+
+;; Numbers get passed though in both directions
+;;
+(define (make-sdb:qry fname)
+ (let ((sdb #f)
+ (scache (make-hash-table))
+ (icache (make-hash-table)))
+ (lambda (cmd var)
+ (case cmd
+ ((setup) (set! sdb (if (not sdb)
+ (sdb:open (if var var fname)))))
+ ((setdb) (set! sdb var))
+ ((getdb) sdb)
+ ((finalize) (if sdb
+ (begin
+ (sqlite3:finalize! sdb)
+ (set! sdb #f))))
+ ((getid) (let ((id (if (or (number? var)
+ (string->number var))
+ var
+ (sdb:string->id sdb scache var))))
+ (if id
+ id
+ (begin
+ (sdb:register-string sdb var)
+ (sdb:string->id sdb scache var)))))
+ ((getstr) (if (or (number? var)
+ (string->number var))
+ (sdb:id->string sdb icache var)
+ var))
+ ((passid) var)
+ ((passstr) var)
+ (else #f)))))
+
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -71,12 +71,18 @@
;;
;; client:setup
;;
;; lookup_server, need to remove *runremote* stuff
;;
-
+
(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
+ (mutex-lock! *rmt-mutex*)
+ (let ((res (client:setup-http-baby areapath remaining-tries: remaining-tries failed-connects: failed-connects area-dat: area-dat)))
+ (mutex-unlock! *rmt-mutex*)
+ res))
+
+(define (client:setup-http-baby areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
(debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
(server:start-and-wait areapath)
(if (<= remaining-tries 0)
(begin
(debug:print-error 0 *default-log-port* "failed to start or connect to server")
@@ -86,11 +92,11 @@
;; through them searching for a good one.
;;
(let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath))
(runremote (or area-dat *runremote*)))
(if (not server-dat) ;; no server found
- (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1))
(let ((host (cadr server-dat))
(port (caddr server-dat))
(server-id (caddr (cddr server-dat))))
(debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if (and (not area-dat)
@@ -108,23 +114,28 @@
(ping-res (case *transport-type*
((http)(rmt:login-no-auto-client-setup start-res)))))
(if (and start-res
ping-res)
(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
- (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
- (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
- start-res)
+ (if runremote
+ (begin
+ (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
+ (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
+ start-res)
+ (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1))))
(begin ;; login failed but have a server record, clean out the record and try again
(debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
(case *transport-type*
((http)(http-transport:close-connections)))
- (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
+ (if *runremote*
+ (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
+ )
(thread-sleep! 1)
- (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1))
)))
(begin ;; no server registered
;; (server:kind-run areapath)
(server:start-and-wait areapath)
(debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
(thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
- (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))
+ (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1)))))))))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -26,12 +26,12 @@
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
-;; (declare (uses commonmod))
-;; (import commonmod)
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
;; (require-library margs)
@@ -129,37 +129,37 @@
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f) ;; used by -log
-(define *common:denoise* (make-hash-table)) ;; for low noise printing
+;; (define *common:denoise* (make-hash-table)) ;; for low noise printing
(define *default-log-port* (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *default-area-tag* "local")
;; DATABASE
-(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
+;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
;; db access
(define *db-last-access* (current-seconds)) ;; last db access, used in server
-(define *db-write-access* #t)
+;; (define *db-write-access* #t)
;; db sync
-(define *db-last-sync* 0) ;; last time the sync to megatest.db happened
+;; (define *db-last-sync* 0) ;; last time the sync to megatest.db happened
(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*
+;; (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-access-mutex* (make-mutex)) ;; moved to dbfile
(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path* #f)
-(define *db-with-db-mutex* (make-mutex))
+;; (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)
+;; (define *no-sync-db* #f) ;; moved to dbfile
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* #f) ;; if set up for server communication this will hold
@@ -172,12 +172,12 @@
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *home-host* #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex* (make-mutex))
-(define *api-process-request-count* 0)
-(define *max-api-process-requests* 0)
+;; (define *api-process-request-count* 0)
+;; (define *max-api-process-requests* 0)
(define *server-overloaded* #f)
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
@@ -310,10 +310,11 @@
(hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
(server-url #f) ;; (server:check-if-running *toppath*) #f))
(server-id #f)
(server-info (if *toppath* (server:check-if-running *toppath*) #f))
(last-server-check 0) ;; last time we checked to see if the server was alive
+ (connect-time (current-seconds))
(conndat #f)
(transport *transport-type*)
(server-timeout (server:expiration-timeout))
(force-server #f)
(ro-mode #f)
@@ -405,19 +406,15 @@
;;
(define (common:cleanup-db dbstruct #!key (full #f))
(apply db:multi-db-sync
dbstruct
'schema
- ;; 'new2old
'killservers
'adj-target
- ;; 'old2new
'new2old
- ;; (if full
- '(dejunk)
- ;; '())
- )
+ '(dejunk)
+ )
(if (common:api-changed?)
(common:set-last-run-version)))
(define (common:snapshot-file filepath #!key (subdir ".") )
(if (file-exists? filepath)
@@ -591,13 +588,13 @@
;;
(define (common:exit-on-version-changed)
(if (common:on-homehost?)
(if (common:api-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
- (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
- (read-only (not (file-write-access? dbfile)))
- (dbstruct (db:setup #t)))
+ (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
+ (read-only (not (file-write-access? dbfile)))
+ (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
@@ -724,54 +721,10 @@
(print-call-chain (current-error-port))
#f)
(read (open-input-string (base64:base64-decode instr))))
(read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
-;; dot-locking egg seems not to work, using this for now
-;; if lock is older than expire-time then remove it and try again
-;; to get the lock
-;;
-(define (common:simple-file-lock fname #!key (expire-time 300))
- (let ((fmod-time (handle-exceptions
- ext
- (current-seconds)
- (file-modification-time fname))))
- (if (common:file-exists? fname)
- (if (> (- (current-seconds) fmod-time) expire-time)
- (begin
- (handle-exceptions exn #f (delete-file* fname))
- (common:simple-file-lock fname expire-time: expire-time))
- #f)
- (let ((key-string (conc (get-host-name) "-" (current-process-id))))
- (with-output-to-file fname
- (lambda ()
- (print key-string)))
- (thread-sleep! 0.25)
- (if (common:file-exists? fname)
- (handle-exceptions exn
- #f
- (with-input-from-file fname
- (lambda ()
- (equal? key-string (read-line)))))
- #f)))))
-
-(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
- (let ((end-time (+ expire-time (current-seconds))))
- (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
- (if got-lock
- #t
- (if (> end-time (current-seconds))
- (begin
- (thread-sleep! 3)
- (loop (common:simple-file-lock fname expire-time: expire-time)))
- #f)))))
-
-(define (common:simple-file-release-lock fname)
- (handle-exceptions
- exn
- #f ;; I don't really care why this failed (at least for now)
- (delete-file* fname)))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
@@ -952,10 +905,22 @@
(begin
(debug:print-error 0 *default-log-port* "Unable to find megatest home directory.")
#f)
(loop (pathname-directory thepath)))))
))
+
+
+(define (common:db-tmp-area-path)
+ (conc "/tmp/"
+ (current-user-name)
+ "/megatest_localdb/"
+ (common:get-testsuite-name)
+ "/"
+ (string-translate *toppath* "/" ".")
+ )
+)
+
;;======================================================================
;; redefine for future cleanup (converge on area-name, the more generic
;;
(define common:get-area-name common:get-testsuite-name)
@@ -979,10 +944,18 @@
"/megatest_localdb/"
tsname
(string-translate *toppath* "/" "."))
))))
(set! *db-cache-path* dbpath)
+ ;; ensure megatest area has .megatest
+ (let ((dbarea (conc *toppath* "/.megatest")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
+ ;; ensure tmp area has .megatest
+ (let ((dbarea (conc dbpath "/.megatest")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
dbpath))
#f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
@@ -999,118 +972,10 @@
(args:get-arg "-server")))
(define (common:human-time)
(time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
-;;======================================================================
-;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
-;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
-;;
-(define (common:readonly-watchdog dbstruct)
- (thread-sleep! 0.05) ;; delay for startup
- (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
- ;; sync megatest.db to /tmp/.../megatst.db
- (let* ((sync-cool-off-duration 3)
- (golden-mtdb (dbr:dbstruct-mtdb dbstruct))
- (golden-mtpath (db:dbdat-get-path golden-mtdb))
- (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
- (tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
- (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
- (let loop ((last-sync-time 0))
- (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
- (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
- (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
- (if (and (not *time-to-exit*)
- (< duration-since-last-sync sync-cool-off-duration))
- (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
- (if (not *time-to-exit*)
- (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
- (tmp-mtdb-mtime (file-modification-time tmp-mtpath)))
- (if (> golden-mtdb-mtime tmp-mtdb-mtime)
- (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
- (let ((res (db:multi-db-sync dbstruct 'old2new)))
- (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
- (loop (current-seconds)))
- #t)))
- (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
-
-;;======================================================================
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define (common:watchdog)
- (debug:print-info 13 *default-log-port* "common:watchdog entered.")
- (if (launch:setup)
- (if (common:on-homehost?)
- (let ((dbstruct (db:setup #t)))
- (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
- (cond
- ((dbr:dbstruct-read-only dbstruct)
- (debug:print-info 13 *default-log-port* "loading read-only watchdog")
- (common:readonly-watchdog dbstruct))
- (else
- (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
- (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
- (cond
- ((equal? syncer "brute-force-sync")
- (server:writable-watchdog-bruteforce dbstruct))
- ((equal? syncer "delta-sync")
- (server:writable-watchdog-deltasync dbstruct))
- (else
- (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")
- (exit 1)))
- ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
- )))
- (debug:print-info 13 *default-log-port* "watchdog done."))
- (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
-
-
-(define (std-exit-procedure)
- ;;(common:telemetry-log-close)
- (on-exit (lambda () 0))
- ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
- (let ((no-hurry (if *time-to-exit* ;; hurry up
- #f
- (begin
- (set! *time-to-exit* #t)
- #t))))
- (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
- (if (and no-hurry (debug:debug-mode 18))
- (rmt:print-db-stats))
- (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
- (if *task-db*
- (let ((db (cdr *task-db*)))
- (if (sqlite3:database? db)
- (begin
- (sqlite3:interrupt! db)
- (sqlite3:finalize! db #t)
- ;; (vector-set! *task-db* 0 #f)
- (set! *task-db* #f)))))
- (http-client#close-all-connections!)
- ;; (if (and *runremote*
- ;; (remote-conndat *runremote*))
- ;; (begin
- ;; (http-client#close-all-connections!))) ;; for http-client
- (if (not (eq? *default-log-port* (current-error-port)))
- (close-output-port *default-log-port*))
- (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
- (th2 (make-thread (lambda ()
- (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
- (if no-hurry
- (begin
- (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
- (begin
- (thread-sleep! 2)))
- (debug:print 4 *default-log-port* " ... done")
- )
- "clean exit")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- )
- )
-
- 0)
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
;;(debug:print-info 13 *default-log-port* "got signal "signum)
@@ -2621,17 +2486,10 @@
;;======================================================================
;; E N V I R O N M E N T V A R S
;;======================================================================
-(define (bb-check-path #!key (msg "check-path: "))
- (let ((path (or (get-environment-variable "PATH") "none")))
- (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
- (if (string-match "^.*/isoenv-core/.*" path)
- (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
- (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))
-
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME")))
;;(bb-check-path msg: "save-environment-as-files entry")
(let ((envvars (get-environment-variables))
(whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]"))
(mungeval (lambda (val)
@@ -2642,13 +2500,16 @@
(with-output-to-file (conc fname ".csh")
(lambda ()
(for-each (lambda (keyval)
(let* ((key (car keyval))
(val (cdr keyval))
- (delim (if (string-search whitesp val)
+ (delim (if (and (string-search whitesp val)
+ (not (string-search "^\".*\"$" val))
+ (not (string-search "^'.*'$" val)))
"\""
"")))
+
(print (if (or (member key ignorevars)
(string-search whitesp key))
"# setenv "
"setenv ")
key " " delim (mungeval val) delim)))
@@ -2656,11 +2517,13 @@
(with-output-to-file (conc fname ".sh")
(lambda ()
(for-each (lambda (keyval)
(let* ((key (car keyval))
(val (cdr keyval))
- (delim (if (string-search whitesp val)
+ (delim (if (and (string-search whitesp val)
+ (not (string-search "^\".*\"$" val))
+ (not (string-search "^'.*'$" val)))
"\""
"")))
(print (if (or (member key ignorevars)
(string-search whitesp key)
(string-search ":" key)) ;; internal only values to be skipped.
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -17,16 +17,19 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit commonmod))
+
+(use srfi-69)
(module commonmod
*
-
+
(import scheme chicken data-structures extras files)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
+(import (prefix sqlite3 sqlite3:)
+ posix typed-records srfi-18 srfi-69
md5 message-digest
regex srfi-1)
;;======================================================================
;; CONTENTS
@@ -44,10 +47,21 @@
(conc megatest-version "-" megatest-fossil-hash))
(define (version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
+(define *common:denoise* (make-hash-table)) ;; for low noise printing
+
+(define (common:low-noise-print waitval . keys)
+ (let* ((key (string-intersperse (map conc keys) "-" ))
+ (lasttime (hash-table-ref/default *common:denoise* key 0))
+ (currtime (current-seconds)))
+ (if (> (- currtime lasttime) waitval)
+ (begin
+ (hash-table-set! *common:denoise* key currtime)
+ #t)
+ #f)))
;;======================================================================
;; config file utils
;;======================================================================
@@ -72,10 +86,55 @@
'()))) ;; should it return empty list or #f to indicate not set?
(define (get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
+
+;; dot-locking egg seems not to work, using this for now
+;; if lock is older than expire-time then remove it and try again
+;; to get the lock
+;;
+(define (common:simple-file-lock fname #!key (expire-time 300))
+ (let ((fmod-time (handle-exceptions
+ ext
+ (current-seconds)
+ (file-modification-time fname))))
+ (if (file-exists? fname) ;; (common:file-exists? fname)
+ (if (> (- (current-seconds) fmod-time) expire-time)
+ (begin
+ (handle-exceptions exn #f (delete-file* fname))
+ (common:simple-file-lock fname expire-time: expire-time))
+ #f)
+ (let ((key-string (conc (get-host-name) "-" (current-process-id))))
+ (with-output-to-file fname
+ (lambda ()
+ (print key-string)))
+ (thread-sleep! 0.25)
+ (if (file-exists? fname) ;; (common:file-exists? fname)
+ (handle-exceptions exn
+ #f
+ (with-input-from-file fname
+ (lambda ()
+ (equal? key-string (read-line)))))
+ #f)))))
+
+(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
+ (let ((end-time (+ expire-time (current-seconds))))
+ (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
+ (if got-lock
+ #t
+ (if (> end-time (current-seconds))
+ (begin
+ (thread-sleep! 3)
+ (loop (common:simple-file-lock fname expire-time: expire-time)))
+ #f)))))
+
+(define (common:simple-file-release-lock fname)
+ (handle-exceptions
+ exn
+ #f ;; I don't really care why this failed (at least for now)
+ (delete-file* fname)))
;;======================================================================
;; misc conversion, data manipulation functions
;;======================================================================
ADDED configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,75 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit configfmod))
+;; (declare (uses mtargs))
+;; (declare (uses debugprint))
+;; (declare (uses keysmod))
+
+(module configfmod
+*
+
+(import srfi-1
+
+;; scheme
+;;
+;; big-chicken ;; more of a reminder than anything ...
+;; chicken.base
+;; chicken.condition
+;; chicken.file
+;; chicken.io
+;; chicken.pathname
+;; chicken.port
+;; chicken.pretty-print
+;; chicken.process
+;; chicken.process-context
+;; chicken.process-context.posix
+;; chicken.sort
+;; chicken.string
+;; chicken.time
+;; chicken.eval
+;;
+;; debugprint
+;; (prefix mtargs args:)
+;; pkts
+;; keysmod
+;;
+;; (prefix base64 base64:)
+;; (prefix dbi dbi:)
+;; (prefix sqlite3 sqlite3:)
+;; (srfi 18)
+;; directory-utils
+;; format
+;; matchable
+;; md5
+;; message-digest
+;; regex
+;; regex-case
+;; sparse-vectors
+;; srfi-1
+;; srfi-13
+;; srfi-69
+;; stack
+;; typed-records
+;; z3
+
+ )
+)
+
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -26,10 +26,11 @@
(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
+(import dbfile)
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
@@ -37,133 +38,74 @@
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
-(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
-;; (declare (uses dashboard-main))
(declare (uses mt))
+(declare (uses dbfile))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
+(dbfile:db-init-proc db:initialize-main-db)
+
(define help (conc
- "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2012-2017
+ "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version
+ " license GPL, Copyright (C) Matt Welland 2012-2017
Usage: dashboard [options]
-h : this help
- -test run-id,test-id : control test identified by testid
+ -test run-id test-id : open a test control panel on this test
-skip-version-check : skip the version check
- -use-db-cache : access database via cache
-
-Misc
-rows R : set number of rows
-cols C : set number of columns
-"))
+ -start-dir dir : start dashboard in the given directory
+ -target target : filter runs tab to given target.
+ -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9
+ -repl : Start a chicken scheme interpreter
+"
+))
-;; -server host:port : connect to host:port instead of db access
-;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
-;; -guimonitor : control panel for runs
;; process args
(define remargs (args:get-args
(argv)
+ ;; parameters (need arguments)
(list "-rows"
"-cols"
- "-run"
- "-test"
- "-xterm"
- "-debug"
- "-host"
- "-transport"
- "-start-dir"
- )
- (list "-h"
- "-use-server"
- "-guimonitor"
- "-main"
- "-v"
- "-q"
- "-use-db-cache"
+ "-test" ;; given a run id and test id, open only a test control panel on that test..
+ "-debug"
+ "-start-dir"
+ "-target"
+ )
+ ;; switches (don't take arguments)
+ (list "-h"
"-skip-version-check"
"-repl"
- "-rh5.11" ;; fix to allow running on rh5.11
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
-;; check for MT_* environment variables and exit if found
-(if (not (args:get-arg "-test"))
- (begin
- (display "Checking for MT_ vars: ")
- (for-each (lambda (var)
- (display " ")(display var)
- (if (get-environment-variable var)
- (begin
- (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
- (exit 1))))
- '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
- (print ". Done. All ok.")))
-
-(if (not (null? remargs))
- (begin
- (print "Unrecognised arguments: " (string-intersperse remargs " "))
- (exit)))
-
-(if (args:get-arg "-h")
- (begin
- (print help)
- (exit)))
-
-(if (args:get-arg "-start-dir")
- (if (directory-exists? (args:get-arg "-start-dir"))
- (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
- (setenv "PWD" fullpath)
- (change-directory fullpath))
- (begin
- (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
- (exit 1))))
-
-;; TODO: Move this inside (main)
-;;
-(if (not (launch:setup))
- (begin
- (print "Failed to find megatest.config, exiting")
- (exit 1)))
-
-;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
-;; first check for the switch
-;;
-(if (or (args:get-arg "-rh5.11")
- (configf:lookup *configdat* "dashboard" "no-detachbox")
- (not (file-exists? "/etc/os-release")))
- (set! iup:detachbox iup:vbox))
-
-(if (not (common:on-homehost?))
- (begin
- (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn")
-(thread-start! (make-thread common:watchdog "Watchdog thread"))
+;; (thread-start! (make-thread common:watchdog "Watchdog thread"))
;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn")
;; (if (not (args:get-arg "-use-db-cache"))
;; (begin
;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
@@ -178,10 +120,11 @@
update-mutex
updaters
updating
uidat ;; needs to move to tabdat at some time
hide-not-hide-tabs
+ target
)
(define (dboard:commondat-make)
(make-dboard:commondat
curr-tab-num: 0
@@ -189,10 +132,11 @@
please-update: #t
update-mutex: (make-mutex)
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
+ target: ""
))
;;======================================================================
;; buttons color using image
;;======================================================================
@@ -260,19 +204,20 @@
tabdat))
;; gets and calls updater list based on curr-tab-num
;;
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
+ (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num))
(if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
(for-each ;; perform the function calls for the complete updaters list
(lambda (updater)
- ;; (debug:print 3 *default-log-port* "Running " updater)
+ ;; (debug:print 3 *default-log-port* "Running " updater)
(updater))
updaters))))
;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; adds the updater passed in the updaters list at that hashkey
@@ -428,14 +373,14 @@
(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"))
+
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
-
(dboard:tabdat-keys-set! tabdat (rmt:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
)
@@ -473,11 +418,11 @@
hierdat ;; put hierarchial sorted list here
tests ;; hash of id => testdat
((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
key-vals
((last-update 0) : number) ;; last query to db got records from before last-update
- ((last-db-time 0) : number) ;; last timestamp on megatest.db
+ ((last-db-time 0) : number) ;; last timestamp on main.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
;; for the new runs view lets build up a few new record types and then consolidate later
@@ -719,11 +664,11 @@
(last-db-time (if do-not-use-db-file-timestamps
0
(dboard:rundat-last-db-time run-dat)))
(db-path (or (dboard:rundat-db-path run-dat)
(let* ((db-dir (common:get-db-tmp-area))
- (db-pth (conc db-dir "/megatest.db")))
+ (db-pth (conc db-dir "/.megatest/main.db")))
(dboard:rundat-db-path-set! run-dat db-pth)
db-pth)))
(db-mod-time (common:lazy-sqlite-db-modification-time db-path))
(db-modified (>= db-mod-time last-db-time))
(multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress
@@ -750,11 +695,11 @@
)
;; if we saw the db modified, reset it (the signal has already been used)
(if (and got-all ;; (not multi-get)
db-modified)
- (dboard:rundat-last-db-time-set! run-dat (- start-time 2)))
+ (dboard:rundat-last-db-time-set! run-dat (- start-time 2)))
;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the
;; data has been read
;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above
@@ -1671,11 +1616,11 @@
;; NAMEid from IupTree to avoid
;; conflict with the common attribute
;; NAME. Use the TITLEid attribute."
#:expand "YES"
#:addexpanded "YES"
- #:size "10x"
+ ;; #:size "10x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
(let* ((run-path (tree:node->path obj id))
@@ -1996,11 +1941,11 @@
(dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
hide-clean: hide-clean)
#f)))
-(define (dashboard:get-runs-hash tabdat)
+(define (dashboard:get-runs-hash tabdat)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
@@ -2783,11 +2728,12 @@
(dboard:runs-tree-new-browser commondat rdat)
(dboard:runs-new-matrix commondat rdat)
)))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
- (let* ((stats-dat (dboard:tabdat-make-data))
+ (let* (
+ (stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
(runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
(onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
@@ -2809,11 +2755,13 @@
(btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat))
(cell-width (dboard:tabdat-runs-cell-width runs-dat))
(use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")))
;; controls (along bottom)
;; (set! controls (dboard:make-controls commondat runs-dat))
-
+
+
+
;; create the left most column for the run key names and the test names
(set! lftlst
(list (iup:hbox
(iup:label) ;; (iup:valuator)
(apply iup:vbox
@@ -2969,14 +2917,14 @@
#:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
#:menu (dcommon:main-menu)
(let* ((runs-view (iup:vbox
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
- #:value 100
+ #:value 250
(dboard:runs-tree-browser commondat runs-dat)
(iup:split
- #:value 100
+ #:value 200
;; left most block, including row names
(apply iup:vbox lftlst)
;; right hand block, including cells
(iup:vbox
#:expand "YES"
@@ -3027,20 +2975,22 @@
(let* ((tab-num (dboard:commondat-curr-tab-num commondat))
(tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-layout-update-ok-set! tabdat #t)))
"tabchangepos"))
- (dashboard:summary commondat stats-dat tab-num: 0)
runs-view
+ (dashboard:summary commondat stats-dat tab-num: 1)
;; (make-runs-view commondat runs2-dat 2)
(dashboard:runs-summary commondat onerun-dat tab-num: 2)
(dashboard:run-controls commondat runcontrols-dat tab-num: 3)
(dashboard:run-times commondat runtimes-dat tab-num: 4)
- additional-views)))
+ additional-views))
+ (target-run (dboard:commondat-target commondat))
+ )
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
- (iup:attribute-set! tabs "TABTITLE0" "Summary")
- (iup:attribute-set! tabs "TABTITLE1" "Runs")
+ (iup:attribute-set! tabs "TABTITLE0" "Runs")
+ (iup:attribute-set! tabs "TABTITLE1" "Summary")
;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
(iup:attribute-set! tabs "TABTITLE3" "Run Control")
(iup:attribute-set! tabs "TABTITLE4" "Run Times")
;; (iup:attribute-set! tabs "TABTITLE3" "New View")
@@ -3054,12 +3004,18 @@
(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
;; make the iup tabs object available (for changing color for example)
(dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
;; now set up the tabdat lookup
- (dboard:common-set-tabdat! commondat 0 stats-dat)
- (dboard:common-set-tabdat! commondat 1 runs-dat)
+ ;; (dboard:common-set-tabdat! commondat 0 stats-dat)
+
+ (if target-run
+ (begin
+ (dboard:tabdat-target-set! runs-dat (string-split target-run "/"))
+ )
+ )
+ (dboard:common-set-tabdat! commondat 0 runs-dat)
;;(dboard:common-set-tabdat! commondat 2 runs2-dat)
(dboard:common-set-tabdat! commondat 2 onerun-dat)
(dboard:common-set-tabdat! commondat 3 runcontrols-dat)
(dboard:common-set-tabdat! commondat 4 runtimes-dat)
@@ -3298,11 +3254,10 @@
(filtrstr (conc targpatt "/" runpatt "/" testpatt)))
;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt)
(if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr))
(let ((dwg (dboard:tabdat-drawing tabdat)))
- (print "reseting drawing")
(dboard:tabdat-layout-update-ok-set! tabdat #f)
(vg:drawing-libs-set! dwg (make-hash-table))
(vg:drawing-insts-set! dwg (make-hash-table))
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
@@ -3360,11 +3315,11 @@
(begin
(debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
#f)))))
(if (and dbpth (file-read-access? dbpth))
(let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
db)
#f)))
;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
;;
@@ -3812,16 +3767,42 @@
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
(define (main)
- (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;;
+ (print "Starting dashboard main")
+
+ (let* ((mtdb-path (conc *toppath* "/.megatest/main.db"))
+ (target (args:get-arg "-target"))
+ (commondat (dboard:commondat-make)))
+ (if target
+ (begin
+ (args:remove-arg-from-ht "-target")
+ (dboard:commondat-target-set! commondat target)
+ )
+ )
+
+ (if (not (launch:setup))
+ (begin
+ (print "Failed to find megatest.config, exiting")
+ (exit 1)
+ )
+ )
+
+ (if (not (common:on-homehost?))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost))
+ (debug:print 0 *default-log-port* "It will be slower.")
+ ))
+
+
(if (and (common:file-exists? mtdb-path)
(file-write-access? mtdb-path))
(if (not (args:get-arg "-skip-version-check"))
(common:exit-on-version-changed)))
- (let* ((commondat (dboard:commondat-make)))
+
+ (let* ()
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(cond
((args:get-arg "-test") ;; run-id,test-id
(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
(if (> (length d) 1)
@@ -3834,26 +3815,24 @@
(>= test-id 0))
(dashboard-tests:examine-test run-id test-id)
(begin
(debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
- ;; ((args:get-arg "-guimonitor")
- ;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
(else
(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat))
(dboard:commondat-curr-tab-num-set! commondat 0)
(dboard:commondat-add-updater
commondat
(lambda ()
- (dashboard:runs-tab-updater commondat 1))
- tab-num: 1)
+ (dashboard:runs-tab-updater commondat 0))
+ tab-num: 0)
;; may not want this alive (manually merged it from v1.66)
- (dboard:commondat-add-updater
- commondat
- (lambda ()
- (dashboard:runs-tab-updater commondat 1))
- tab-num: 2)
+ ;; (dboard:commondat-add-updater
+ ;; commondat
+ ;; (lambda ()
+ ;; (dashboard:runs-tab-updater commondat 1))
+ ;; tab-num: 2)
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (time-obj)
(let ((update-is-running #f))
(mutex-lock! (dboard:commondat-update-mutex commondat))
@@ -3867,23 +3846,102 @@
(mutex-lock! (dboard:commondat-update-mutex commondat))
(dboard:commondat-updating-set! commondat #f)
(mutex-unlock! (dboard:commondat-update-mutex commondat)))
))
1))))
-
+ (print "Starting updaters")
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
+ (print "Starting main loop")
(thread-start! th2)
- (thread-join! th2)))))
+ (thread-join! th2)
+ )
+ )
+ )
+)
+
+(define last-copy-time 0)
+
+
+;; Sync to tmp only if in read-only mode.
+
+(define (sync-db-to-tmp tabdat)
+ (let* ((db-file "./.megatest/main.db"))
+ (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
+ (begin
+ (db:multi-db-sync (db:setup #f) 'old2new)
+ (set! last-copy-time (current-seconds))
+ )
+ )
+ )
+)
+
+;; ########################### top level code ########################
+;; check for MT_* environment variables and exit if found
+(if (not (args:get-arg "-test"))
+ (begin
+ (for-each (lambda (var)
+ ;; (display " ")(display var)
+ (if (get-environment-variable var)
+ (begin
+ (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
+ (exit 1))))
+ '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
+ )
+)
+
+(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD"))
+
+(if (not (null? remargs))
+ (if remargs
+ (begin
+ (print "Unrecognised arguments: " (string-intersperse remargs " "))
+ (exit)
+ )
+ (begin
+ (print help)
+ (exit)
+ )
+ )
+)
+
+(if (args:get-arg "-h")
+ (begin
+ (print help)
+ (exit)))
+
+
+
+
+(if (args:get-arg "-start-dir")
+ (if (directory-exists? (args:get-arg "-start-dir"))
+ (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
+ (setenv "PWD" fullpath)
+ (change-directory fullpath))
+ (begin
+ (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
+ (exit 1))))
+
+
+;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
+;; first check for the switch
+;;
+(if (or
+ (configf:lookup *configdat* "dashboard" "no-detachbox")
+ (not (file-exists? "/etc/os-release")))
+ (set! iup:detachbox iup:vbox))
+
+
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
+
(if (args:get-arg "-repl")
(repl)
(main))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -22,17 +22,37 @@
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-(use (srfi 18) extras tcp stack)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
+(use (srfi 18)
+ extras
+ tcp
+ stack
+ (prefix sqlite3 sqlite3:)
+ srfi-1
+ posix
+ regex
+ regex-case
+ srfi-69
+ csv-xml
+ s11n
+ md5
+ message-digest
+ (prefix base64 base64:)
+ format
+ dot-locking
+ z3
+ typed-records
+ matchable
+ files)
(declare (unit db))
(declare (uses common))
+(declare (uses dbmod))
+;; (declare (uses debugprint))
+(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
@@ -42,43 +62,21 @@
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
-;;======================================================================
-;; R E C O R D S
-;;======================================================================
-
-;; each db entry is a pair ( db . dbfilepath )
-;; I propose this record evolves into the area record
-;;
-(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)
- (stmt-cache (make-hash-table))
- ) ;; goal is to converge on one struct for an area but for now it is too confusing
-
+(import dbmod)
+(import dbfile)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
-;;======================================================================
-;; alist-of-alists
-;;======================================================================
-;;
-;; (define (db:aa-set! dat key1 key2 val)
-;; (let loop ((
;;======================================================================
;; hash of hashs
;;======================================================================
@@ -94,13 +92,14 @@
(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))))
-(define (db:get-cache-stmth dbstruct db stmt)
- (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
- (stmth (db:hoh-get stmt-cache db stmt)))
+(define (db:get-cache-stmth dbdat run-id db stmt)
+ (let* (;; (dbdat (dbfile:get-dbdat dbstruct run-id))
+ (stmt-cache (dbr:dbdat-stmt-cache dbdat))
+ (stmth (db:hoh-get stmt-cache db stmt)))
(or stmth
(let* ((newstmth (sqlite3:prepare db stmt)))
(db:hoh-set! stmt-cache db stmt newstmth)
newstmth))))
@@ -127,37 +126,63 @@
(begin
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
+
+(define (db:setup do-sync)
+ (assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
+ (let* ((tmpdir (common:get-db-tmp-area)))
+ (if (not *dbstruct-dbs*)
+ (dbfile:setup do-sync *toppath* tmpdir)
+ *dbstruct-dbs*)))
+
+;; 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))))
;; Get/open a database
;; if run-id => get run specific db
;; if #f => get main db
+;; if run-id is a string treat it as a filename
;; 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)
- (if (pair? dbdat)
- (car dbdat)
- dbdat))
-
-(define (db:dbdat-get-path dbdat)
- (if (pair? dbdat)
- (cdr dbdat)
- #f))
+;; (define db:get-db db:get-subdb)
+
+;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh
+;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+;; (if (stack? (dbr:subdb-dbstack subdb))
+;; (if (stack-empty? (dbr:subdb-dbstack subdb))
+;; (let* ((dbname (db:run-id->dbname run-id))
+;; (newdb (db:open-megatest-db path: (db:dbfile-path)
+;; name: dbname)))
+;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used
+;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
+;; newdb)
+;; (stack-pop! (dbr:subdb-dbstack subdb)))
+;; (db:open-db subdb run-id))) ;; )
+
+
+#;(define (db:get-db dbstruct run-id)
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id))
+ (dbdat (dbfile:get-dbdat dbstruct run-id)))
+ (if (dbr:dbdat? dbdat)
+ dbdat
+ (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)
+ )
+ )
+)
(define-inline (db:generic-error-printout exn . message)
(print-call-chain (current-error-port))
(apply debug:print-error 0 *default-log-port* message)
(debug:print-error 0 *default-log-port* " params: " params
@@ -164,71 +189,10 @@
", error: " ((condition-property-accessor 'exn 'message) exn)
", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
", location: " ((condition-property-accessor 'exn 'location) exn)
))
-;; (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))
- (fname (db:dbdat-get-path dbdat))
- (use-mutex (> *api-process-request-count* 25))) ;; was 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*))
- (condition-case
- (begin
- (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))
- (exn (io-error)
- (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
- (exn (corrupt)
- (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
- (exn (busy)
- (db:generic-error-printout exn "ERROR: database " fname
- " is locked. Try copying to another location, remove original and copy back."))
- (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
- (exn ()
- (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
- ((condition-property-accessor 'exn 'message) exn))))))
-
-;;======================================================================
-;; 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
-;; db
-;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
-;; (vector-set! dbstruct 2 fdb)
-;; fdb))))
-;;
-;; ;; Can also be used to save arbitrary strings
-;; ;;
-;; (define (db:save-path dbstruct path)
-;; (let ((fdb (db:get-filedb dbstruct)))b
-;; (filedb:register-path fdb path)))
-;;
-;; ;; Use to get a path. To get an arbitrary string see next define
-;; ;;
-;; (define (db:get-path dbstruct id)
-;; (let ((fdb (db:get-filedb dbstruct)))
-;; (filedb:get-path db id)))
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
@@ -242,12 +206,12 @@
;; 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)
+;;
+#;(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
@@ -312,182 +276,113 @@
(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
+#;(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) ;; get previously opened db (will create new db handle if all in the stack are already used
+ (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
+ (dbpath (db:dbfile-path)) ;; path to tmp db area
+ (dbname (db:run-id->dbname run-id))
(dbexists (common:file-exists? dbpath))
- (tmpdbfname (conc dbpath "/megatest.db"))
+ (mtdbfname (conc *toppath* "/"dbname))
+ (mtdbexists (common:file-exists? mtdbfname))
+ (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f))
+ (mtdb (db:open-megatest-db mtdbfname))
+ ;; the reference db for syncing
+ (refdbfname (conc dbpath "/"dbname"_ref"))
+ (refndb (db:open-megatest-db refdbfname))
+ ;; (mtdbpath (dbr:dbdat-dbfile mtdb))
+ ;; the tmpdb
+ (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db
+ (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-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))
+ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
+
+ (write-access (file-write-access? mtdbfname))
+
+ ;; (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))))
(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"))
+ (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
+ (sqlite3:execute (dbr:dbdat-dbh 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)
+ ;; (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)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
- (dbr:dbstruct-refndb-set! dbstruct refndb)
+ (dbr:subdb-read-only-set! subdb #t)))
+ (dbr:subdb-mtdb-set! subdb mtdb)
+ (dbr:subdb-tmpdb-set! subdb tmpdb)
+ (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
+ (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
+ (dbr:subdb-refndb-set! subdb refndb)
(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 1 *default-log-port* "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
+ (db:sync-tables (db:sync-all-tables-list subdb) #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
+ (debug:print 4 *default-log-port* " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
+ ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
(define (db:get-last-update-time db)
-; (db:with-db
-; dbstruct #f #f
-; (lambda (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))))
+ (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))
+
;; Open the classic megatest.db file (defaults to open in toppath)
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
-
-;;(define (db:reopen-megatest-db
-
-(define (db:open-megatest-db #!key (path #f)(name #f))
- (let* ((dbdir (or path *toppath*))
- (dbpath (conc dbdir "/" (or name "megatest.db")))
- (dbexists (common:file-exists? dbpath))
+(define (db:open-megatest-db dbpath)
+ (let* ((dbexists (file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
- (db:initialize-main-db db)
- ;;(db:initialize-run-id-db db)
- )))
+ (db:initialize-main-db db))))
(write-access (file-write-access? dbpath)))
(debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
- (cons db dbpath)))
-
-;; sync run to disk if touched
-;;
-(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
- (let ((tmpdb (db:get-db dbstruct))
- (mtdb (dbr:dbstruct-mtdb dbstruct))
- (refndb (dbr:dbstruct-refndb dbstruct))
- (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*)
- (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
- (mutex-lock! *db-multi-sync-mutex*)
- (set! *db-last-sync* start-t)
- (set! *db-last-access* start-t)
- (mutex-unlock! *db-multi-sync-mutex*)
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
-
-(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
- (if (<= try-num 0)
- #f
- (handle-exceptions
- exn
- (begin
- (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
- (thread-sleep! 3)
- (sqlite3:interrupt! db)
- (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
- (if (sqlite3:database? db)
- (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
- (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
- (sqlite3:finalize! db)
- #t)
- #f))))
-
-;; close all opened run-id dbs
-(define (db:close-all dbstruct)
- (if (dbr:dbstruct? dbstruct)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
- (print-call-chain *default-log-port*))
- ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
- (let ((tdbs (map db:dbdat-get-db
- (stack->list (dbr:dbstruct-dbstack dbstruct))))
- (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
- (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))
- (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
- (map (lambda (db)
- (db:safely-close-sqlite3-db db stmt-cache))
- tdbs)
- (db:safely-close-sqlite3-db mdb stmt-cache) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
- (db:safely-close-sqlite3-db rdb stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+ ;; (cons db dbpath)))
+ (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
+
+
+
+;; db:safely-close-sqlite3-db and db:close-all were here, moved to dbfile
;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;; (if (hash-table? locdbs)
;; (for-each (lambda (run-id)
;; (db:close-run-db dbstruct run-id))
@@ -498,114 +393,14 @@
;; (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 "archive_disks"
- '("id" #f)
- '("archive_area_name" #f)
- '("disk_path" #f)
- '("last_df" #f)
- '("last_df_time" #f)
- '("creation_time" #f))
-
- (list "archive_blocks"
- '("id" #f)
- '("archive_disk_id" #f)
- '("disk_path" #f)
- '("last_du" #f)
- '("last_du_time" #f)
- '("creation_time" #f))
-
- (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))
+ (let* ((dbpath (dbr:dbdat-dbfile dbdat))
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath))
(fnamejnl (conc fname "-journal"))
(tmpname (conc fname "." (current-process-id)))
(tmpjnl (conc fnamejnl "." (current-process-id))))
@@ -622,11 +417,11 @@
;; return #f to indicate the dbdat should be closed/reopened
;; else return dbdat
;;
(define (db:repair-db dbdat #!key (numtries 1))
- (let* ((dbpath (db:dbdat-get-path dbdat))
+ (let* ((dbpath (dbr:dbdat-dbfile dbdat))
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath)))
(debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
(cond
((not (file-write-access? dbdir))
@@ -675,213 +470,10 @@
(sqlite3:execute db "vacuum;")))
(sqlite3:finalize! db)
#t))))))
-;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
-;; db's are dbdat's
-;;
-;; if last-update specified ("field-name" . time-in-seconds)
-;; then sync only records where field-name >= time-in-seconds
-;; IFF field-name exists
-;;
-(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
- (for-each (lambda (dbdat)
- (let ((dbpath (db:dbdat-get-path dbdat)))
- (debug:print 0 *default-log-port* " dbpath: " dbpath)
- (if (not (db:repair-db dbdat))
- (begin
- (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
- (exit)))))
- (cons todb slave-dbs))
-
- 0)
- ;; this is the work to be done
- (cond
- ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
- -1)
- ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
- -2)
- ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
- (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
- -3)
- ((not (sqlite3:database? (db:dbdat-get-db todb)))
- (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
- -4)
-
- ((not (file-write-access? (db:dbdat-get-path todb)))
- (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
- -5)
- ((not (null? (let ((readonly-slave-dbs
- (filter
- (lambda (dbdat)
- (not (file-write-access? (db:dbdat-get-path todb))))
- slave-dbs)))
- (for-each
- (lambda (bad-dbdat)
- (debug:print-error
- 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
- readonly-slave-dbs)
- readonly-slave-dbs))) -6)
- (else
- (let ((stmts (make-hash-table)) ;; table-field => stmt
- (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
- (numrecs (make-hash-table))
- (start-time (current-milliseconds))
- (tot-count 0))
- (for-each ;; table
- (lambda (tabledat)
- (let* ((tablename (car tabledat))
- (fields (cdr tabledat))
- (has-last-update (member "last_update" fields))
- (use-last-update (cond
- ((and has-last-update
- (member "last_update" fields))
- #t) ;; if given a number, just use it for all fields
- ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
- ((and (pair? last-update)
- (member (car last-update) ;; last-update field name
- (map car fields)))
- #t)
- (last-update
- (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
- #f)
- (else
- #f)))
- (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
- (if (number? last-update)
- last-update
- (cdr last-update))
- #f))
- (last-update-field (if use-last-update
- (if (number? last-update)
- "last_update"
- (car last-update))
- #f))
- (num-fields (length fields))
- (field->num (make-hash-table))
- (num->field (apply vector (map car fields))) ;; BBHERE
- (full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
- " FROM " tablename (if use-last-update ;; apply last-update criteria
- (conc " WHERE " last-update-field " >= " last-update-value)
- "")
- ";"))
- (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
- " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
- (fromdat '())
- (fromdats '())
- (totrecords 0)
- (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
- (todat (make-hash-table))
- (count 0)
- (field-names (map car fields))
- (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
- )
-
- ;; set up the field->num table
- (for-each
- (lambda (field)
- (hash-table-set! field->num field count)
- (set! count (+ count 1)))
- fields)
-
- ;; read the source table
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! fromdat (cons (apply vector a b) fromdat))
- (if (> (length fromdat) batch-len)
- (begin
- (set! fromdats (cons fromdat fromdats))
- (set! fromdat '())
- (set! totrecords (+ totrecords 1)))))
- (db:dbdat-get-db fromdb)
- full-sel)
-
- ;; tack on remaining records in fromdat
- (if (not (null? fromdat))
- (set! fromdats (cons fromdat fromdats)))
-
- (if (common:low-noise-print 120 "sync-records")
- (debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
-
- ;; read the target table; BBHERE
- (sqlite3:for-each-row
- (lambda (a . b)
- (hash-table-set! todat a (apply vector a b)))
- (db:dbdat-get-db todb)
- full-sel)
-
- (when (and delay-handicap (> delay-handicap 0))
- (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
- (thread-sleep! delay-handicap)
- (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
- )
-
- ;; first pass implementation, just insert all changed rows
- (for-each
- (lambda (targdb)
- (let* ((db (db:dbdat-get-db targdb))
- (drp-trigger (if (member "last_update" field-names)
- (db:drop-trigger db tablename)
- #f))
- (is-trigger-dropped (if (member "last_update" field-names)
- (db:is-trigger-dropped db tablename)
- #f))
- (stmth (sqlite3:prepare db full-ins)))
- ;; (db:delay-if-busy targdb) ;; NO WAITING
- (if (member "last_update" field-names)
- (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped))
- (for-each
- (lambda (fromdat-lst)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each ;;
- (lambda (fromrow)
- (let* ((a (vector-ref fromrow 0))
- (curr (hash-table-ref/default todat a #f))
- (same #t))
- (let loop ((i 0))
- (if (or (not curr)
- (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
- (set! same #f))
- (if (and same
- (< i (- num-fields 1)))
- (loop (+ i 1))))
- (if (not same)
- (begin
- (apply sqlite3:execute stmth (vector->list fromrow))
- (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
- fromdat-lst))))
- fromdats)
- (sqlite3:finalize! stmth)
- (if (member "last_update" field-names)
- (db:create-trigger db tablename))))
- (append (list todb) slave-dbs))))
- tbls)
- (let* ((runtime (- (current-milliseconds) start-time))
- (should-print (or (debug:debug-mode 12)
- (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
- (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
- (for-each
- (lambda (dat)
- (let ((tblname (car dat))
- (count (cdr dat)))
- (set! tot-count (+ tot-count count))
- (if (> count 0)
- (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
- (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
- tot-count)))))
(define (db:patch-schema-rundb frundb)
;;
;; remove this some time after September 2016 (added in version v1.6031
;;
@@ -1042,20 +634,74 @@
;; (lambda ()
;; (if (and (common:file-exists? megatest-db)
;; (file-write-access? megatest-db))
;; (begin
;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync*
-;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
+;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
;; "call-with-cached-db sync-to-megatest.db"))
;; (cache-db (db:cache-for-read-only
;; megatest-db
;; (conc cache-dir "/" fname)
;; use-last-update: #t)))
;; (thread-start! th1)
;; (apply proc cache-db params)
;; ))))
+
+
+
+(define (db:all-db-sync dbstruct)
+ (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
+ (data-synced 0) ;; count of changed records
+ (tmp-area (common:get-db-tmp-area))
+ (dbfiles (glob (conc tmp-area"/.megatest/*.db")))
+ (sync-durations (make-hash-table))
+ (no-sync-db (db:open-no-sync-db)))
+ (for-each
+ (lambda (file)
+ (debug:print-info 3 *default-log-port* "file: " file)
+ (let* ((fname (conc (pathname-file file) ".db"))
+ (fulln (conc *toppath*"/.megatest/"fname))
+ (time1 (if (file-exists? file)
+ (file-modification-time file)
+ (begin
+ (debug:print-info 2 *default-log-port* "Sync - I do not see file "file)
+ 1)))
+ (time2 (if (file-exists? fulln)
+ (file-modification-time fulln)
+ (begin
+ (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln)
+ 0)))
+ (changed (> (- time1 time2) (+ (random 5) 1))) ;; it has been at some few seconds since last synced
+ (changed10 (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd
+ (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy?
+ (do-cp (cond
+ ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
+ (cons #t (conc "File "fulln" not found! Copying "fname" to "fulln)))
+ ((and (not jfile-exists) changed)
+ (cons #t "not busy, changed")) ;; not busy and changed
+ ((and jfile-exists changed10)
+ (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds
+ ((and changed *time-to-exit*)
+ (cons #t "Time to exit, forced final sync")) ;; last sync
+ (else
+ (cons #f "No sync needed")))))
+ (if (car do-cp)
+ (let* ((start-time (current-milliseconds))
+ (fname (pathname-file file))
+ (runid (if (string= fname "main") #f (string->number fname))))
+ (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: "
+ fname", delta: " (- time1 time2) " seconds, reason: "(cdr do-cp))
+ (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db)
+ (hash-table-set! sync-durations (conc fname".db")
+ (- (current-milliseconds) start-time)))
+ (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date")
+ )))
+ dbfiles)
+ (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)))
+ #t)
+
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
;; 'adj-testids - move test-ids into correct ranges
@@ -1064,26 +710,27 @@
;; 'closeall - close all opened dbs
;; 'schema - attempt to apply schema changes
;; run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync dbstruct . options)
- ;; (if (not (launch:setup))
- ;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
- (let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
- (tmpdb (db:get-db dbstruct))
- (refndb (dbr:dbstruct-refndb dbstruct))
- (allow-cleanup #t) ;; (if run-ids #f #t))
- (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
- (data-synced 0)) ;; count of changed records (I hope)
-
- (for-each
- (lambda (option)
-
- (case option
- ;; kill servers
- ((killservers)
- (for-each
+ (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc))
+ (data-synced 0) ;; count of changed records
+ (tmp-area (common:get-db-tmp-area))
+ (old2new (member 'old2new options))
+ (dejunk (member 'dejunk options))
+ (killservers (member 'killservers options))
+ (servers (server:get-list *toppath*))
+ (src-area (if old2new *toppath* tmp-area))
+ (dest-area (if old2new tmp-area *toppath*))
+ (dbfiles (if old2new (glob (conc *toppath* "/.megatest/*.db")) (glob (conc tmp-area "/.megatest/*.db"))))
+ (keys (db:get-keys dbstruct))
+ (sync-durations (make-hash-table)))
+
+
+ (if killservers
+ (begin
+ (for-each
(lambda (server)
(handle-exceptions
exn
(begin
(debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn)
@@ -1090,61 +737,95 @@
#f)
(match-let (((mod-time host port start-time server-id pid) server))
(if (and host pid)
(tasks:kill-server host pid)))))
servers)
-
- ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
(delete-file* (common:get-sync-lock-filepath))
- )
-
- ;; clear out junk records
- ;;
- ((dejunk)
- ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
- (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
- (db:clean-up tmpdb)
- (db:clean-up refndb))
-
- ;; sync runs, test_meta etc.
- ;;
- ((old2new)
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
- data-synced)))
-
- ;; now ensure all newdb data are synced to megatest.db
- ;; do not use the run-ids list passed in to the function
- ;;
- ((new2old)
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
- data-synced)))
-
- ((adj-target)
- (db:adj-target (db:dbdat-get-db mtdb))
- (db:adj-target (db:dbdat-get-db tmpdb))
- (db:adj-target (db:dbdat-get-db refndb)))
-
- ((schema)
- (db:patch-schema-maindb (db:dbdat-get-db mtdb))
- (db:patch-schema-maindb (db:dbdat-get-db tmpdb))
- (db:patch-schema-maindb (db:dbdat-get-db refndb))
- (db:patch-schema-rundb (db:dbdat-get-db mtdb))
- (db:patch-schema-rundb (db:dbdat-get-db tmpdb))
- (db:patch-schema-rundb (db:dbdat-get-db refndb))))
-
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
- options)
- data-synced))
-
-(define (db:tmp->megatest.db-sync dbstruct last-update)
- (let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
- (tmpdb (db:get-db dbstruct))
- (refndb (dbr:dbstruct-refndb dbstruct))
- (res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
+ )
+ )
+ (for-each
+ (lambda (srcfile)
+ (debug:print-info 3 *default-log-port* "file: " srcfile)
+ (let* ((fname (conc (pathname-file srcfile) ".db"))
+ (basename (pathname-file srcfile))
+ (run-id (if (string= basename "main") #f (string->number basename)))
+ (destfile (conc dest-area "/.megatest/" fname))
+ (dest-directory (conc dest-area "/.megatest/"))
+ (dummy (debug:print-info 2 *default-log-port* "destfile = " destfile))
+ (dummy2 (debug:print-info 2 *default-log-port* "dejunk = " dejunk))
+ (time1 (file-modification-time srcfile))
+ (time2 (if (file-exists? destfile)
+ (begin
+ (debug:print-info 2 *default-log-port* "destfile " destfile " exists")
+ (file-modification-time destfile)
+ )
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile)
+ 0)))
+ (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds
+
+ (do-cp (cond
+ ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover
+ (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile)
+ (system (conc "/bin/mkdir -p " dest-directory))
+ (system (conc "/bin/cp " srcfile " " destfile))
+ #t)
+ (changed ;; (and changed
+ ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
+ #t)
+ ((and changed *time-to-exit*) ;; last sync
+ #t)
+ (else
+ #f))))
+ (if (or dejunk do-cp)
+ (let* (
+ (start-time (current-milliseconds))
+
+ (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
+ (mtdb (dbr:subdb-mtdbdat subdb))
+ (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc))
+
+ )
+ (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
+
+ (if old2new
+ (begin
+ (if dejunk (db:clean-up run-id mtdb))
+ (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb)
+ )
+ (begin
+ (if dejunk (db:clean-up run-id tmpdb))
+ (db:sync-tables (db:sync-all-tables-list dbstruct (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* ((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 (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
+ ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
+ (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
@@ -1186,11 +867,11 @@
(print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
(exit)
(if (or *db-write-access*
(not #t)) ;; was: (member proc * db:all-write-procs *)))
(let* ((db (cond
- ((pair? idb) (db:dbdat-get-db idb))
+ ((pair? idb) (dbr:dbdat-dbh idb))
((sqlite3:database? idb) idb)
((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
((procedure? idb) (idb))
(else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
(res #f))
@@ -1223,107 +904,20 @@
#;(define open-run-close open-run-close-exception-handling)
;; open-run-close-no-exception-handling
;; open-run-close-exception-handling)
;;)
-(define db:trigger-list
- (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
- FOR EACH ROW
- BEGIN
- UPDATE runs SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;" )
- (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
- FOR EACH ROW
- BEGIN
- UPDATE run_stats SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;" )
- (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
- FOR EACH ROW
- BEGIN
- UPDATE tests SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;" )
- (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
- FOR EACH ROW
- BEGIN
- UPDATE test_steps SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;" )
- (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
- FOR EACH ROW
- BEGIN
- UPDATE test_data SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;" )))
-
-(define (db:create-all-triggers dbstruct)
-(db:with-db
- dbstruct #f #f
- (lambda (db)
-(db:create-triggers db))))
-
-(define (db:create-triggers db)
- (for-each (lambda (key)
- (sqlite3:execute db (cadr key)))
- db:trigger-list))
-
-(define (db:drop-all-triggers dbstruct)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (db:drop-triggers db))))
-
-(define (db:is-trigger-dropped db tbl-name)
- (let* ((trigger-name (if (equal? tbl-name "test_steps")
- "update_teststeps_trigger"
- (conc "update_" tbl-name "_trigger")))
- (res #f))
- (sqlite3:for-each-row
- (lambda (name)
- (if (equal? name trigger-name)
- (set! res #t)))
- db
- "SELECT name FROM sqlite_master WHERE type = 'trigger' ;"
- )))
-
-(define (db:drop-triggers db)
- (for-each
- (lambda (key)
- (sqlite3:execute db (conc "drop trigger if exists " (car key))))
- db:trigger-list))
-
-(define (db:drop-trigger db tbl-name)
- (let* ((trigger-name (if (equal? tbl-name "test_steps")
- "update_teststeps_trigger"
- (conc "update_" tbl-name "_trigger"))))
- (for-each
- (lambda (key)
- (if (equal? (car key) trigger-name)
- (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
- db:trigger-list)))
-
-(define (db:create-trigger db tbl-name)
- (let* ((trigger-name (if (equal? tbl-name "test_steps")
- "update_teststeps_trigger"
- (conc "update_" tbl-name "_trigger"))))
- (for-each (lambda (key)
- (if (equal? (car key) trigger-name)
- (sqlite3:execute db (cadr key))))
- db:trigger-list)))
-
-
-(define (db:initialize-main-db dbdat)
+
+(define (db:initialize-main-db db)
(when (not *configinfo*)
(launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys:make-key/field-string configdat))
- (db (db:dbdat-get-db dbdat)))
+ #;(db (dbr:dbdat-dbh dbdat)))
(for-each (lambda (key)
(let ((keyn key))
(if (member (string-downcase keyn)
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
"pass_count" "contour"))
@@ -1539,11 +1133,10 @@
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
- (print "creating triggers from init")
(db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
@@ -1552,12 +1145,12 @@
;; 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)) ;; archive tables are in main.db
- (db (db:dbdat-get-db dbdat))
+ (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)))
@@ -1577,19 +1170,19 @@
"SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
last_df > ?;")
dneeded))
- (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+ (dbfile:add-dbdat dbstruct #f 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)) ;; archive tables are in main.db
- (db (db:dbdat-get-db dbdat))
+ (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
@@ -1598,28 +1191,28 @@
(if res ;; record exists, update df and return id
(begin
(sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
WHERE archive_area_name=? AND disk_path=?;"
df bdisk-name bdisk-path)
- (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+ (dbfile:add-dbdat dbstruct #f dbdat)
res)
(begin
(sqlite3:execute
db
"INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
VALUES (?,?,?);"
bdisk-name bdisk-path df)
- (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+ (dbfile:add-dbdat dbstruct #f dbdat)
(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)) ;; archive tables are in main.db
- (db (db:dbdat-get-db dbdat))
+ (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))
@@ -1633,11 +1226,11 @@
(begin
(sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
VALUES (?,?,?);"
bdisk-id archive-path (or du 0))
(set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
- (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+ (dbfile:add-dbdat dbstruct #f dbdat)
res))
;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
;;
@@ -1644,11 +1237,11 @@
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
archive-block-id test-id))))
;; Look up the archive block info given a block-id
;;
@@ -1655,11 +1248,11 @@
(define (db:test-get-archive-block-info dbstruct archive-block-id)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
;; 0 1 2 3 4 5
(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
(set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
@@ -1667,12 +1260,12 @@
"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 (db:dbdat-get-db dbdat))
+;; (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)
;;======================================================================
@@ -1724,12 +1317,12 @@
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
72000))) ;; twenty hours
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
;; HOWEVER: this code in run:test seems to work fine
@@ -1774,12 +1367,12 @@
(define (db:get-status-from-final-status-file run-dir)
(let ((infile (conc run-dir "/.final-status")))
;; first verify we are able to write the output file
(if (not (file-read-access? infile))
(begin
- (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
- (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
+ (debug:print 2 *default-log-port* "ERROR: cannot read " infile)
+ (debug:print 2 *default-log-port* "ERROR: run-dir is " run-dir)
#f
)
(with-input-from-file infile read-lines)
)))
@@ -1807,24 +1400,24 @@
)
(debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
(debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(let* ((stmth1 (db:get-cache-stmth
- dbstruct db
+ dbdat run-id db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
AND state IN ('RUNNING');"))
(stmth2 (db:get-cache-stmth
- dbstruct db
+ dbdat run-id db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
AND state IN ('REMOTEHOSTSTART');"))
(stmth3 (db:get-cache-stmth
- dbstruct db
+ dbdat run-id db
"SELECT id,rundir,uname,testname,item_path FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400
AND state IN ('LAUNCHED');")))
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
@@ -1928,11 +1521,11 @@
)))))))
;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
- (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
+ (db:general-call dbstruct run-id 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
@@ -1941,54 +1534,20 @@
;; b. If test dir gone, delete the test record
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
-(define (db:clean-up dbdat)
- ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
- (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d"))))
- (db (db:dbdat-get-db dbdat))
- (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
- (statements
- (map (lambda (stmt)
- (sqlite3:prepare db stmt))
- (list
- ;; delete all tests that belong to runs that are 'deleted'
- (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";")
- ;; delete all tests that are 'DELETED'
- (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;")
- ;; delete all tests that have no run
- (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ")
- ;; delete all runs that are state='deleted'
- (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";")
- ;; delete empty runs
- (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";")
- ;; remove orphaned test_rundat entries
- (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);")
- ;; remove orphaned test_steps entries
- (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);")
- ;; remove orphaned test_dat entries
- (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);")
-
- ))))
- ;; (db:delay-if-busy dbdat)
- ;(debug:print-info 0 *default-log-port* statements)
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
- count-stmt)
- (map sqlite3:execute statements)
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Records count after clean: " tot))
- count-stmt)))
- (map sqlite3:finalize! statements)
- (sqlite3:finalize! count-stmt)
- ;; (db:find-and-mark-incomplete db)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "VACUUM;")))
+(define (db:clean-up run-id dbdat)
+ (debug:print 2 *default-log-port* "db:clean-up")
+
+
+ (if run-id
+ (db:clean-up-rundb dbdat)
+ (db:clean-up-maindb dbdat)
+ )
+)
+
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
@@ -1999,11 +1558,11 @@
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up-rundb dbdat)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
- (let* ((db (db:dbdat-get-db dbdat))
+ (let* ((db (dbr:dbdat-dbh dbdat))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
@@ -2040,11 +1599,11 @@
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up-maindb dbdat)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
- (let* ((db (db:dbdat-get-db dbdat))
+ (let* ((db (dbr:dbdat-dbh dbdat))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
@@ -2085,12 +1644,12 @@
;; also updates *global-delta*
;;
(define (db:get-var dbstruct var)
(let* ((res #f))
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct #f #f ;; for the moment vars are only stored in main.db
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM metadat WHERE var=?;" var)
@@ -2100,16 +1659,16 @@
(if valnum (set! res valnum))))
res))))
(define (db:inc-var dbstruct var)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
(define (db:dec-var dbstruct var)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
@@ -2122,99 +1681,49 @@
;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
;; (set! *last-global-delta-printed* *global-delta*)))
(define (db:set-var dbstruct var val)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
(define (db:add-var dbstruct var val)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
(define (db:del-var dbstruct var)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(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 (sqlite3:make-busy-timeout 136000))
- (if (not db-exists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
- (sqlite3:execute db "PRAGMA journal_mode=WAL;")))
- db))
-
-;; if we are not a server create a db handle. this is not finalized
-;; so watch for problems. I'm still not clear if it is needed to manually
-;; finalize sqlite3 dbs with the sqlite3 egg.
-;;
(define (db:no-sync-db db-in)
- (mutex-lock! *db-access-mutex*)
- (let ((res (if db-in
- db-in
- (let ((db (db:open-no-sync-db)))
- (set! *no-sync-db* db)
- db))))
- (mutex-unlock! *db-access-mutex*)
- res))
-
-(define (db:no-sync-set db var val)
- (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
-
-(define (db:no-sync-del! db var)
- (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))
-
-(define (db:no-sync-get/default db var default)
- (let ((res default))
- (sqlite3:for-each-row
- (lambda (val)
- (set! res val))
- (db:no-sync-db db)
- "SELECT val FROM no_sync_metadat WHERE var=?;"
- var)
- (if res
- (let ((newres (if (string? res)
- (string->number res)
- #f)))
- (if newres
- newres
- res))
- res)))
+ (if db-in
+ db-in
+ (if *no-sync-db*
+ *no-sync-db*
+ (begin
+ (mutex-lock! *db-access-mutex*)
+ (let ((dbpath (common:get-db-tmp-area))
+ (db (dbfile:open-no-sync-db dbpath)))
+ (set! *no-sync-db* db)
+ (mutex-unlock! *db-access-mutex*)
+ db)))))
+
+(define (with-no-sync-db proc)
+ (let* ((db (db:no-sync-db *no-sync-db*)))
+ (proc db)))
+
+(define (db:open-no-sync-db)
+ (dbfile:open-no-sync-db (db:dbfile-path)))
(define (db:no-sync-close-db db stmt-cache)
(db:safely-close-sqlite3-db db stmt-cache))
-
-;; transaction protected lock aquisition
-;; either:
-;; fails returns (#f . lock-creation-time)
-;; succeeds (returns (#t . lock-creation-time)
-;; use (db:no-sync-del! db keyname) to release the lock
-;;
-(define (db:no-sync-get-lock db-in keyname)
- (let ((db (db:no-sync-db db-in)))
- (sqlite3:with-transaction
- db
- (lambda ()
- (handle-exceptions
- exn
- (let ((lock-time (current-seconds)))
- (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn)
- (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
- `(#t . ,lock-time))
- `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)))))))
-
;; 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
@@ -2221,21 +1730,24 @@
;; 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)))
+ (keys:config-get-fields *configdat*)
+)
+
+;; (if *db-keys* *db-keys*
+;; (let ((res '()))
+;; (db:with-db dbstruct #f #f
+;; (lambda (dbdat 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)))
;; extract index number given a header/data structure
(define (db:get-index-by-header header field)
(list-index (lambda (x)(equal? x field)) header))
@@ -2275,11 +1787,11 @@
;(print qry)
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (runname runtime target )
(set! res (cons (vector runname runtime target) res)))
db
qry
@@ -2292,11 +1804,11 @@
(define (db:get-run-name-from-id dbstruct run-id)
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (runname)
(set! res runname))
db
@@ -2307,11 +1819,11 @@
(define (db:get-run-key-val dbstruct run-id key)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
@@ -2351,18 +1863,22 @@
(andstr (if (> (length keys) 0) " AND " ""))
(valslots (keys->valslots keys)) ;; ?,?,? ...
(allvals (append (list runname state status user contour) (map cadr keyvals)))
(qryvals (append (list runname) (map cadr keyvals)))
(key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
+ ;; (debug:print 0 *default-log-port* "Got here 0.")
(debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
(debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
(if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
+ ;; (debug:print 0 *default-log-port* "Got here 1.")
(let ((res #f))
- (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
+ (apply sqlite3:execute db
+ (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour"
+ comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
allvals)
(apply sqlite3:for-each-row
(lambda (id)
(set! res id))
db
@@ -2406,11 +1922,11 @@
(if (number? offset)
(conc " OFFSET " offset)
""))))
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (cons (apply vector a x) res)))
db
qrystr
@@ -2449,11 +1965,11 @@
(conc " OFFSET " offset)
"")))
)
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (target id runname state status owner event_time)
(set! res (cons (make-simple-run target id runname state status owner event_time) res)))
db
qrystr
@@ -2461,19 +1977,21 @@
(debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
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)
;;
+;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .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")))
+ (alldbs (glob (conc dbdir "/.megatest/[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)))
+ (let* ((res (string-match ".*\\/(\\d\\d)\\.db" dbfile)))
(if res
(string->number (cadr res))
(begin
(debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
0))))
@@ -2490,11 +2008,11 @@
(seen (make-hash-table)))
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(let ((targ (cons a x)))
(if (not (hash-table-ref/default seen targ #f))
(begin
@@ -2509,11 +2027,11 @@
(define (db:get-num-runs dbstruct runpatt)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((numruns 0))
(debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt)
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
@@ -2526,11 +2044,11 @@
(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((numruns 0)
(qry-str #f)
(key-patt "")
(keyvals (if targetpatt (keys:target->keyval keys targetpatt) '())))
@@ -2564,11 +2082,11 @@
(define (db:get-raw-run-stats dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:fold-row
(lambda (res state status count)
(cons (list state status count) res))
'()
db
@@ -2583,11 +2101,11 @@
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
;; remove previous data
(let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
(stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
(res
@@ -2607,11 +2125,11 @@
(define (db:get-main-run-stats dbstruct run-id)
(db:with-db
dbstruct
#f ;; this data comes from main
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:fold-row
(lambda (res state status count)
(cons (list state status count) res))
'()
db
@@ -2640,11 +2158,11 @@
(define (db:get-all-run-ids dbstruct)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((run-ids '()))
(sqlite3:for-each-row
(lambda (run-id)
(set! run-ids (cons run-id run-ids)))
db
@@ -2664,11 +2182,11 @@
(res '())
(runs-info '()))
;; First get all the runname/run-ids
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (run-id runname)
(set! runs-info (cons (list run-id runname) runs-info)))
db
"SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
@@ -2680,11 +2198,11 @@
(run-name (cadr run-info)))
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (state status count)
(let ((netstate (if (equal? state "COMPLETED") status state)))
(if (string? netstate)
(begin
@@ -2742,11 +2260,11 @@
;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
(vector header
(reverse
(db:with-db dbstruct #f #f ;; reads db, does not write to it.
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:fold-row
(lambda (res . r)
(cons (list->vector r) res))
'()
db
@@ -2768,11 +2286,11 @@
(string-intersperse remfields ","))))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
db
(conc "SELECT " keystr " FROM runs WHERE id=?;")
@@ -2783,19 +2301,19 @@
finalres)))
(define (db:set-comment-for-run dbstruct run-id comment)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
run-id))))
;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run dbstruct run-id)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
(sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
@@ -2804,17 +2322,17 @@
(sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
(define (db:update-run-event_time dbstruct run-id)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))
(define (db:lock/unlock-run dbstruct run-id lock unlock user)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(let ((newlockval (if lock "locked"
(if unlock
"unlocked"
"locked")))) ;; semi-failsafe
(sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
@@ -2823,28 +2341,28 @@
(debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
(define (db:set-run-status dbstruct run-id status msg)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(if msg
(sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
(sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))
(define (db:set-run-state-status dbstruct run-id state status )
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id))))
(define (db:get-run-status dbstruct run-id)
(let ((res "n/a"))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
db
"SELECT status FROM runs WHERE id=?;"
@@ -2853,11 +2371,11 @@
(define (db:get-run-state dbstruct run-id)
(let ((res "n/a"))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
db
"SELECT state FROM runs WHERE id=?;"
@@ -2874,11 +2392,11 @@
(define (db:get-key-val-pairs dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
(res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
(sqlite3:for-each-row
(lambda (key-val)
@@ -2891,11 +2409,11 @@
(define (db:get-key-vals dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
(res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
@@ -2923,11 +2441,11 @@
(let ((prev-run-ids '()))
(if (null? keyvals)
'()
(begin
(db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
- (lambda (db)
+ (lambda (dbdat db)
(apply sqlite3:for-each-row
(lambda (id)
(set! prev-run-ids (cons id prev-run-ids)))
db
(conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;")
@@ -3018,11 +2536,11 @@
(if offset (conc " OFFSET " offset) " ")
";"
)))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
(let* ((res (db:with-db dbstruct run-id #f
- (lambda (db)
+ (lambda (dbdat db)
;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
(reverse
(sqlite3:fold-row
(lambda (res . row)
;; id run-id testname state status event-time host cpuload
@@ -3055,11 +2573,11 @@
;; 3. convert for-each-row to fold
;;
;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
;; (db:with-db
;; dbstruct run-id #f
-;; (lambda (db)
+;; (lambda (dbdat db)
;; (let* ((res '())
;; (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
;; (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt)))
;; (or sh
;; (let* ((tests-match-qry (tests:match->sqlqry testpatt))
@@ -3085,11 +2603,11 @@
" AND last_update > ? "
(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
)))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
(db:with-db dbstruct run-id #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:fold-row
(lambda (res id testname item-path state status event-time run-duration)
;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res))
'()
@@ -3099,11 +2617,11 @@
(or last-update 0))))))
(define (db:get-testinfo-state-status dbstruct run-id test-id)
(let ((res #f))
(db:with-db dbstruct run-id #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (run-id testname item-path state status)
;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
db
@@ -3134,15 +2652,15 @@
;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;
(define (db:delete-test-records dbstruct run-id test-id)
- (db:general-call dbstruct 'delete-test-step-records (list test-id))
- (db:general-call dbstruct 'delete-test-data-records (list test-id))
+ (db:general-call dbstruct run-id 'delete-test-step-records (list test-id))
+ (db:general-call dbstruct run-id 'delete-test-data-records (list test-id))
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
;;
(define (db:delete-old-deleted-test-records dbstruct)
(let ((targtime (- (current-seconds)
@@ -3150,11 +2668,11 @@
(* 30 24 60 60))))) ;; one month in the past
(db:with-db
dbstruct
0
#t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timenumber "id" db:test-record-fields))))
- (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
+ (db:adj-test-id (dbr:dbdat-dbh mtdb) min-test-id test-id)))
testrecs)))
;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
@@ -3469,21 +2986,21 @@
(define (db:prep-megatest.db-for-migration mtdb)
(let* ((run-ids (db:get-all-run-ids mtdb)))
(for-each
(lambda (run-id)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
- (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
+ (db:prep-megatest.db-adj-test-ids (dbr:dbdat-dbh mtdb) run-id testrecs)))
run-ids)))
;; Get test data using test_id, run-id is not used
;;
(define (db:get-test-info-by-id dbstruct run-id test-id)
(db:with-db
dbstruct
- #f ;; run-id
+ run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
(set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)))
@@ -3498,11 +3015,11 @@
(define (db:get-test-info-by-ids dbstruct run-id test-ids)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (a . b)
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
(set! res (cons (apply vector a b) res)))
@@ -3514,11 +3031,11 @@
(define (db:get-test-info dbstruct run-id test-name item-path)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (apply vector a b)))
db
@@ -3529,11 +3046,11 @@
(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(db:first-result-default
db
"SELECT rundir FROM tests WHERE id=?;"
#f ;; default result
test-id))))
@@ -3545,11 +3062,11 @@
" as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (test-name item-path test-time target )
(set! res (cons (vector test-name item-path test-time) res)))
db
qry
@@ -3563,11 +3080,11 @@
(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
(db:with-db
dbstruct
run-id
#t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute
db
"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
test-id teststep-name state-in status-in (current-seconds)
(if comment comment "")
@@ -3579,11 +3096,11 @@
;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) )
(db:with-db
dbstruct
run-id
#t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute
db
"UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps
test-id))))
@@ -3592,26 +3109,26 @@
(define (db:get-steps-for-test dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((res '()))
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile comment)
(set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
db
"SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
test-id)
(reverse res)))))
- (define (db:get-steps-info-by-id dbstruct test-step-id)
+ (define (db:get-steps-info-by-id dbstruct run-id test-step-id)
(db:with-db
dbstruct
- #f
+ run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((res (vector #f #f #f #f #f #f #f #f #f)))
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile comment last-update)
(set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
db
@@ -3622,11 +3139,11 @@
(define (db:get-steps-data dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile)
(set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
db
@@ -3636,18 +3153,18 @@
;;======================================================================
;; T E S T D A T A
;;======================================================================
-(define (db:get-data-info-by-id dbstruct test-data-id)
+(define (db:get-data-info-by-id dbstruct run-id test-data-id)
(let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
(db:with-db
dbstruct
- #f
+ run-id
#f
- (lambda (db)
- (let* ((stmth (db:get-cache-stmth dbstruct db stmt))
+ (lambda (dbdat db)
+ (let* ((stmth (db:get-cache-stmth dbdat #f db stmt))
(res (sqlite3:fold-row
(lambda (res id test-id category variable value expected tol units comment status type last-update)
(vector id test-id category variable value expected tol units comment status type last-update))
(vector #f #f #f #f #f #f #f #f #f #f #f #f)
stmth
@@ -3661,24 +3178,24 @@
;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup dbstruct run-id test-id status)
(let* ((fail-count 0)
(pass-count 0))
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (fcount pcount)
(set! fail-count fcount)
(set! pass-count pcount))
db
"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
test-id test-id)
;; Now rollup the counts to the central megatest.db
- (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
+ (db:general-call dbstruct run-id 'pass-fail-counts (list pass-count fail-count test-id))
;; if the test is not FAIL then set status based on the fail and pass counts.
- (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
+ (db:general-call dbstruct run-id 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
;; each section is a rule except "final" which is the final result
;;
;; [rule-5]
;; operator in
@@ -3761,11 +3278,11 @@
(define (db:csv->test-data dbstruct run-id test-id csvdata)
(debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((csvlist (csv->list (make-csv-reader
(open-input-string csvdata)
'((strip-leading-whitespace? #t)
(strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
(for-each
@@ -3824,11 +3341,11 @@
;;
(define (db:read-test-data dbstruct run-id test-id categorypatt)
(let* ((res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
db
"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
@@ -3838,11 +3355,11 @@
;;
(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt)
(let* ((res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
db
"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt)
@@ -3854,11 +3371,11 @@
;;======================================================================
(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((row-ids '())
(keystr (string-intersperse
(map (lambda (key val)
(conc key " like '" val "'"))
keynames
@@ -3881,11 +3398,11 @@
(tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
tstsqry
@@ -3895,11 +3412,11 @@
(define (db:test-toplevel-num-items dbstruct run-id testname)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res 0))
(sqlite3:for-each-row
(lambda (num-items)
(set! res num-items))
db
@@ -3946,11 +3463,11 @@
(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)))
+;; (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)))
@@ -3961,11 +3478,11 @@
;; (mt:process-triggers dbstruct run-id test-id state status)))
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
-;; if test-name is an integer work off that instead of test-name test-path
+;; if test-name is an integer work off that as test-id instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
;; establish info on incoming test followed by info on top level test
;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
(let* ((testdat (if (number? test-name)
@@ -3979,26 +3496,26 @@
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (if tl-testdat
(db:test-get-id tl-testdat)
#f)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (db:general-call dbstruct 'set-test-start-time (list test-id)))
+ (db:general-call dbstruct run-id 'set-test-start-time (list test-id)))
(mutex-lock! *db-transaction-mutex*)
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
;; NB// Pass the db so it is part fo the transaction
(db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
- (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
- (state-stauses (db:roll-up-rules state-status-counts state status))
- (newstate (car state-stauses))
- (newstatus (cadr state-stauses)))
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
+ (state-statuses (db:roll-up-rules state-status-counts state status))
+ (newstate (car state-statuses))
+ (newstatus (cadr state-statuses)))
(debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: "
(apply conc
(map (lambda (x)
(conc
(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
@@ -4011,88 +3528,87 @@
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
tr-res)))))
(define (db:roll-up-rules state-status-counts state status)
- (let* ((running (length (filter (lambda (x)
- (member (dbr:counts-state x) *common:running-states*))
- state-status-counts)))
- (bad-not-started (length (filter (lambda (x)
- (and (equal? (dbr:counts-state x) "NOT_STARTED")
- (not (member (dbr:counts-status x) *common:not-started-ok-statuses*))))
- state-status-counts)))
- (all-curr-states (common:special-sort ;; worst -> best (sort of)
- (delete-duplicates
- (if (and state (not (member state *common:dont-roll-up-states*)))
- (cons state (map dbr:counts-state state-status-counts))
- (map dbr:counts-state state-status-counts)))
- *common:std-states* >))
- (all-curr-statuses (common:special-sort ;; worst -> best
- (delete-duplicates
- (if (and state status (not (member state *common:dont-roll-up-states*)))
- (cons status (map dbr:counts-status state-status-counts))
- (map dbr:counts-status state-status-counts)))
- *common:std-statuses* >))
- (non-completes (filter (lambda (x)
- (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
- all-curr-states))
- (preq-fails (filter (lambda (x)
- (equal? x "PREQ_FAIL"))
- all-curr-statuses))
- (num-non-completes (length non-completes))
- (newstate (cond
- ((> running 0) "RUNNING") ;; anything running, call the situation running
- ((> (length preq-fails) 0) "NOT_STARTED")
- ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
- ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
- (else (car all-curr-states))))
- (newstatus (cond
- ((> (length preq-fails) 0) "PREQ_FAIL")
- ((or (> bad-not-started 0)
- (and (equal? newstate "NOT_STARTED")
- (> num-non-completes 0)))
- "STARTED")
- (else (car all-curr-statuses)))))
- (debug:print-info 2 *default-log-port*
- "\n--> probe db:set-state-status-and-roll-up-items: "
- "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
- "\n--> running: "running
- "\n--> bad-not-started: "bad-not-started
- "\n--> non-non-completes: "num-non-completes
- "\n--> non-completes: "non-completes
- "\n--> all-curr-states: "all-curr-states
- "\n--> all-curr-statuses: "all-curr-statuses
- "\n--> newstate "newstate
- "\n--> newstatus "newstatus
- "\n\n")
-
- ;; NB// Pass the db so it is part of the transaction
- (list newstate newstatus)))
+ (let* ((running (length (filter (lambda (x)
+ (member (dbr:counts-state x) *common:running-states*))
+ state-status-counts)))
+ (bad-not-started (length (filter (lambda (x)
+ (and (equal? (dbr:counts-state x) "NOT_STARTED")
+ (not (member (dbr:counts-status x) *common:not-started-ok-statuses*))))
+ state-status-counts)))
+ (all-curr-states (common:special-sort ;; worst -> best (sort of)
+ (delete-duplicates
+ (if (and state (not (member state *common:dont-roll-up-states*)))
+ (cons state (map dbr:counts-state state-status-counts))
+ (map dbr:counts-state state-status-counts)))
+ *common:std-states* >))
+ (all-curr-statuses (common:special-sort ;; worst -> best
+ (delete-duplicates
+ (if (and state status (not (member state *common:dont-roll-up-states*)))
+ (cons status (map dbr:counts-status state-status-counts))
+ (map dbr:counts-status state-status-counts)))
+ *common:std-statuses* >))
+ (non-completes (filter (lambda (x)
+ (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
+ all-curr-states))
+ (preq-fails (filter (lambda (x)
+ (equal? x "PREQ_FAIL"))
+ all-curr-statuses))
+ (num-non-completes (length non-completes))
+ (newstate (cond
+ ((> running 0) "RUNNING") ;; anything running, call the situation running
+ ((> (length preq-fails) 0) "NOT_STARTED")
+ ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
+ ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
+ (else (car all-curr-states))))
+ (newstatus (cond
+ ((> (length preq-fails) 0) "PREQ_FAIL")
+ ((or (> bad-not-started 0)
+ (and (equal? newstate "NOT_STARTED")
+ (> num-non-completes 0)))
+ "STARTED")
+ (else (car all-curr-statuses)))))
+ (debug:print-info 2 *default-log-port*
+ "\n--> probe db:set-state-status-and-roll-up-items: "
+ "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
+ "\n--> running: "running
+ "\n--> bad-not-started: "bad-not-started
+ "\n--> non-non-completes: "num-non-completes
+ "\n--> non-completes: "non-completes
+ "\n--> all-curr-states: "all-curr-states
+ "\n--> all-curr-statuses: "all-curr-statuses
+ "\n--> newstate "newstate
+ "\n--> newstatus "newstatus
+ "\n\n")
+
+ ;; NB// Pass the db so it is part of the transaction
+ (list newstate newstatus)))
(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
(mutex-lock! *db-transaction-mutex*)
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
- (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id))
- (state-stauses (db:roll-up-rules state-status-counts #f #f ))
- (newstate (car state-stauses))
- (newstatus (cadr state-stauses)))
- (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
- (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-run db run-id))
+ (state-statuses (db:roll-up-rules state-status-counts #f #f ))
+ (newstate (car state-statuses))
+ (newstatus (cadr state-statuses)))
+ (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
+ (db:set-run-state-status db run-id newstate newstatus )))))))
(mutex-unlock! *db-transaction-mutex*)
tr-res))))
-
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
(let* ((test-count-recs (db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
"SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;"
@@ -4107,12 +3623,12 @@
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
(let* ((test-info (db:get-test-info dbstruct run-id test-name item-path))
(item-state (or item-state-in (db:test-get-state test-info)))
(item-status (or item-status-in (db:test-get-status test-info)))
(other-items-count-recs (db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
;; ignore current item because we have changed its value in the current transation so this select will see the old value.
@@ -4157,11 +3673,11 @@
(define (db:test-get-logfile-info dbstruct run-id test-name)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path final_logf)
;; (let ((path (sdb:qry 'getstr path-id))
;; (final_logf (sdb:qry 'getstr final_logf-id)))
@@ -4343,29 +3859,30 @@
(else
(hash-table-set! *logged-in-clients* client-signature (current-seconds))
'(#t "successful login"))))
-(define (db:general-call dbstruct stmtname params)
+(define (db:general-call dbstruct run-id stmtname params)
+ ;; Why is db:lookup-query above not used here to get the query?
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(apply sqlite3:execute db query params)
#t))))
;; get a summary of state and status counts to calculate a rollup
;;
(define (db:get-state-status-summary dbstruct run-id testname)
(let ((res '()))
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (state status count)
(set! res (cons (vector state status count) res)))
db
"SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
@@ -4375,11 +3892,11 @@
(define (db:get-latest-host-load dbstruct raw-hostname)
(let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
(res (cons -1 0)))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (cpuload update-time) (set! res (cons cpuload update-time)))
db
"SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;"
hostname))) res ))
@@ -4420,11 +3937,11 @@
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . b)
(set! keyvals (cons a b)))
db
(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)))
@@ -4431,11 +3948,11 @@
(if (not keyvals)
'()
(let ((prev-run-ids '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(apply sqlite3:for-each-row
(lambda (id)
(set! prev-run-ids (cons id prev-run-ids)))
db
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))))
@@ -4467,14 +3984,14 @@
;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval
;; return the sqlite3 db handle if possible
;;
(define (db:delay-if-busy dbdat #!key (count 6))
(if (not (configf:lookup *configdat* "server" "delay-on-busy"))
- (and dbdat (db:dbdat-get-db dbdat))
+ (and dbdat (dbr:dbdat-dbh dbdat))
(if dbdat
- (let* ((dbpath (db:dbdat-get-path dbdat))
- (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
+ (let* ((dbpath (dbr:dbdat-dbfile dbdat))
+ (db (dbr:dbdat-dbh dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
(dbfj (conc dbpath "-journal")))
(if (handle-exceptions
exn
(begin
(debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn)
@@ -4510,11 +4027,11 @@
(let ((res '()))
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id itempath state status run_duration logf comment)
(set! res (cons (vector id itempath state status run_duration logf comment) res)))
db
"SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id?
@@ -4529,11 +4046,11 @@
;; returns a hash table of tags to tests
;;
(define (db:get-tests-tags dbstruct)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((res (make-hash-table)))
(sqlite3:for-each-row
(lambda (testname tags-in)
(let ((tags (string-split tags-in ",")))
(for-each
@@ -4551,11 +4068,11 @@
(let ((res #f))
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
(set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
db
"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
@@ -4563,26 +4080,26 @@
res))))
;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute
db
"INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))))
;; update one of the testmeta fields
(define (db:testmeta-update-field dbstruct testname field value)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute
db
(conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))
(define (db:testmeta-get-all dbstruct)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (cons (apply vector a b) res)))
db
@@ -4830,50 +4347,160 @@
;;======================================================================
;; To sync individual run
;;======================================================================
(define (db:get-run-record-ids dbstruct target run keynames test-patt)
-(let ((backcons (lambda (lst item)(cons item lst))))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (let* ((keystr (string-intersperse
- (map (lambda (key val)
+ (let* ((backcons (lambda (lst item)(cons item lst)))
+ (all_tests '())
+ (all_test_steps '())
+ (all_test_data '())
+ (keystr (string-intersperse
+ (map (lambda (key val)
(conc key " like '" val "'"))
- keynames
- (string-split target "/"))
- " AND "))
+ keynames
+ (string-split target "/"))
+ " AND ")
+ )
(run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'"))
- (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")))
- (print run-qry)
- (print test-qry)
- `((runs . ,(sqlite3:fold-row backcons '() db run-qry))
- (tests . ,(sqlite3:fold-row backcons '() db test-qry))
- (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
- (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" )))
- ))))))
+ (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))
+ (run_ids
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db run-qry))
+ )
+ )
+ )
+ (for-each
+ (lambda (run_id)
+ (set! all_tests
+ (append
+ (map (lambda (x) (cons x run_id))
+ (db:with-db dbstruct run_id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db (conc "SELECT id FROM tests WHERE run_id in (" run_id ") and testname like '" test-patt "'"))
+ )
+ )
+ ) all_tests
+ )
+ )
+ (set! all_test_steps
+ (append
+ (map (lambda (x) (cons x run_id))
+ (db:with-db dbstruct run_id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))
+ )
+ )
+ ) all_test_steps
+ )
+ )
+ (set! all_test_data
+ (append
+ (map (lambda (x) (cons x run_id))
+ (db:with-db dbstruct run_id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")"))
+ )
+ )
+ ) all_test_data
+ )
+ )
+ )
+ run_ids
+ )
+ `((runs . ,run_ids)
+ (tests . ,all_tests)
+ (test_steps . ,all_test_steps)
+ (test_data . ,all_test_data)
+ )
+
+ )
+)
;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================
-;; get an alist of record ids changed since time since-time
-;; '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...))
+;; get an alist of run ids and test/run, test_step/run pairs changed since time since-time
+;; '((runs . (1 2 3 ...))(tests . ((5 . 1) (6 . 3) (6 . 2) (7 . 1) ...
;;
(define (db:get-changed-record-ids dbstruct since-time)
;; no transaction, allow the db to be accessed between the big queries
- (let ((backcons (lambda (lst item)(cons item lst))))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- `((runs . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
- (tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
- (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
- (test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
- ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time))
- (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
- )))))
+ (let* ((backcons (lambda (lst item)(cons item lst)))
+ (all_tests '())
+ (all_test_steps '())
+ (all_test_data '())
+ (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers
+ (all_run_ids
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))
+ )
+ )
+ (changed_run_ids (filter (lambda (run) (member (modulo run 100) changed_run_dbs)) all_run_ids))
+ (run_ids
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
+ )
+ )
+ (run_stat_ids
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
+ )
+ )
+ )
+ (for-each
+ (lambda (run_id)
+ (set! all_tests
+ (append
+ (map (lambda (x) (cons x run_id))
+ (db:with-db dbstruct run_id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time)
+ )
+ )
+ ) all_tests
+ )
+ )
+ (set! all_test_steps
+ (append
+ (map (lambda (x) (cons x run_id))
+ (db:with-db dbstruct run_id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)
+ )
+ )
+ ) all_test_steps
+ )
+ )
+ (set! all_test_data
+ (append
+ (map (lambda (x) (cons x run_id))
+ (db:with-db dbstruct run_id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)
+ )
+ )
+ ) all_test_data
+ )
+ )
+ )
+ changed_run_ids
+ )
+ (debug:print 2 *default-log-port* "run_ids = " run_ids)
+ (debug:print 2 *default-log-port* "all_tests = " all_tests)
+
+ `((runs . ,run_ids)
+ (tests . ,all_tests)
+ (test_steps . ,all_test_steps)
+ (test_data . ,all_test_data)
+ (run_stats . ,run_stat_ids)
+ )
+ )
+)
;;======================================================================
;; Extract ods file from the db
;;======================================================================
@@ -4880,16 +4507,17 @@
;; NOT REWRITTEN YET!!!!!
;; runspatt is a comma delimited list of run patterns
;; 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 (db:dbdat-get-db dbdat))
+ (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
@@ -4996,11 +4624,427 @@
(begin
(debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
(conc (current-directory) "/" outputfile)))
results)
;; brutal clean up
- (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+ (dbfile:add-dbdat dbstruct #f dbdat)
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
+;;======================================================================
+;; moving watch dogs here due to dependencies
+;;======================================================================
+
+;;======================================================================
+;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
+;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
+;;
+(define (common:readonly-watchdog dbstruct)
+ (thread-sleep! 0.05) ;; delay for startup
+ (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
+ ;; sync megatest.db to /tmp/.../megatst.db
+ (let* ((sync-cool-off-duration 3)
+ (golden-mtdb (dbr:dbstruct-mtdb dbstruct))
+ (golden-mtpath (db:dbdat-get-path golden-mtdb))
+ (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
+ (tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
+ (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
+ (let loop ((last-sync-time 0))
+ (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
+ (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
+ (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
+ (if (and (not *time-to-exit*)
+ (< duration-since-last-sync sync-cool-off-duration))
+ (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
+ (if (not *time-to-exit*)
+ (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
+ (tmp-mtdb-mtime (file-modification-time tmp-mtpath)))
+ (if (> golden-mtdb-mtime tmp-mtdb-mtime)
+ (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
+ (let ((res (db:multi-db-sync dbstruct 'old2new)))
+ (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
+ (loop (current-seconds)))
+ #t)))
+ (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
+
+;;======================================================================
+;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
+#;(define (common:watchdog)
+ (debug:print-info 13 *default-log-port* "common:watchdog entered.")
+ (if (launch:setup)
+ (if (common:on-homehost?)
+ (let ((dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
+ (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
+ (cond
+ ((dbr:dbstruct-read-only dbstruct)
+ (debug:print-info 13 *default-log-port* "loading read-only watchdog")
+ (common:readonly-watchdog dbstruct))
+ (else
+ (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
+ (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "delta-sync"))) ;; "brute-force-sync")))
+ (cond
+ ((equal? syncer "brute-force-sync")
+ (server:writable-watchdog-bruteforce dbstruct))
+ ((equal? syncer "delta-sync")
+ (server:writable-watchdog-deltasync dbstruct))
+ ((equal? syncer "copy-sync")
+ (server:writable-watchdog-copysync dbstruct))
+ (else
+ (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are copy-sync, brute-force-sync and delta-sync.")
+ (exit 1)))
+ ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
+ )))
+ (debug:print-info 13 *default-log-port* "watchdog done."))
+ (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
+
+
+#;(define (db:do-sync no-sync-db)
+ (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))
+ (dbstruct (db:setup #t)))
+
+ (debug:print 0 *default-log-port* "db:do-sync: sync-method: " syncer)
+ (cond
+ ((equal? syncer "brute-force-sync")
+ (db:run-lock-and-sync no-sync-db))
+ ((equal? syncer "delta-sync")
+ (debug:print 0 *default-log-port* "db:do-sync: db:multi-db-sync" )
+ (let* (
+ (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
+ (lockfile (conc tmpdbpth ".lock"))
+ (locked (common:simple-file-lock lockfile))
+ (res (if locked
+ ;; sync all dbs for this area
+
+
+
+
+ (db:all-db-sync dbstruct)
+ #f
+ )
+ )
+ )
+ (if res
+ (begin
+ (common:simple-file-release-lock lockfile)
+ (print "db:do-sync: Synced " res " records to megatest.db")
+ )
+ (print "db:do-sync: Skipping sync, there is a sync in progress.")
+ )
+ )
+ )
+ ((equal? syncer "copy-sync")
+ (db:run-lock-and-sync *no-sync-db*))
+ (else
+ (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are copy-sync, brute-force-sync and delta-sync.")
+ (exit 1)
+ )
+ )
+ )
+)
+
+
+
+
+#;(define (server:writable-watchdog-bruteforce dbstruct)
+ (thread-sleep! 1) ;; delay for startup
+ #;(let* ((do-a-sync (server:get-bruteforce-syncer dbstruct))
+ (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t)))
+ (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync
+ (args:get-arg "-server"))
+
+ (let loop ()
+ (do-a-sync)
+ (if (not *time-to-exit*) (loop))) ;; keep going unless time to exit
+
+ ;; time to exit, close the no-sync db here
+ (final-sync)
+
+ (if (common:low-noise-print 30)
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)
+ ))))
+ )
+
+
+;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f
+
+(define (db:lock-and-sync no-sync-db from-db to-db)
+ (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
+ (let* ((lockdat (db:no-sync-get-lock no-sync-db from-db))
+ (gotlock (car lockdat))
+ (locktime (cdr lockdat)))
+ (if gotlock
+ (begin
+ (file-copy from-db to-db #t)
+ (db:no-sync-del! no-sync-db from-db)
+ #t)
+ (begin
+ (debug:print 0 *default-log-port* "could not get lock for " from-db " from no-sync-db")
+ #f
+ ))))
+
+;; sync for filesystem local db writes
+;;
+(define (db:run-lock-and-sync no-sync-db)
+ (let* ((tmp-area (common:get-db-tmp-area))
+ (dbfiles (glob (conc tmp-area"/.megatest/*.db")))
+ (sync-durations (make-hash-table)))
+ ;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles)
+ (for-each
+ (lambda (file)
+ (let* ((fname (conc (pathname-file file) ".db"))
+ (fulln (conc *toppath*"/.megatest/"fname))
+ (time1 (if (file-exists? file)
+ (file-modification-time file)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
+ 1)))
+ (time2 (if (file-exists? fulln)
+ (file-modification-time fulln)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln)
+ 0)))
+ (changed (> time1 time2))
+ (do-cp (cond
+ ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
+ (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln)
+ #t)
+ (changed ;; (and changed
+ ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
+ #t)
+ ((and changed *time-to-exit*) ;; last copy
+ #t)
+ (else
+ #f))))
+ (if do-cp
+ (let* ((start-time (current-milliseconds)))
+ (debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds")
+ (db:lock-and-sync no-sync-db file fulln)
+ (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
+ #;(debug:print-info 0 *default-log-port* "skipping sync..."))))
+ dbfiles)
+ (hash-table->alist sync-durations)))
+
+;; straight forward copy based sync
+;; 1. for each .db fil
+;; 2. next if file changed since last sync cycle
+;; 2. next if time delta /tmp file to MTRA less than 3 seconds
+;; 3. get a lock for the file in nosyncdb
+;; 4. copy the file
+;; 5. when copy is done release the lock
+;;
+;; DONE
+(define (server:writable-watchdog-copysync dbstruct)
+ (thread-sleep! 0.05) ;; delay for startup
+ (let ((legacy-sync (common:run-sync?))
+ (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
+ (debug-mode (debug:debug-mode 1))
+ (last-time (current-seconds)) ;; last time through the sync loop
+ (no-sync-db (db:open-no-sync-db))
+ (sync-duration 0) ;; run time of the sync in milliseconds
+ (tmp-area (common:get-db-tmp-area)))
+ ;; Sync moved to http-transport keep-running loop
+ (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
+ (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area)
+ (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num)
+
+ (if (and legacy-sync (not *time-to-exit*))
+ (begin
+ (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.")
+ (let loop ()
+
+ ;; run the sync and print out durations
+ (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db))
+ ;; keep going unless time to exit
+ ;;
+ (if (not *time-to-exit*)
+ (let delay-loop ((count 0))
+ ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
+
+ (if (and (not *time-to-exit*)
+ (< count 6)) ;; was 11, changing to 4.
+ (begin
+ (thread-sleep! 1)
+ (delay-loop (+ count 1))))
+ (if (not *time-to-exit*) (loop))))
+
+ ;; ==> ;; time to exit, close the no-sync db here
+ ;; ==> (db:no-sync-close-db no-sync-db stmt-cache)
+ (if (common:low-noise-print 30)
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = "
+ *time-to-exit*" pid="(current-process-id) )))))))
+
+(define (server:writable-watchdog-deltasync dbstruct)
+ ;; This is awful complex and convoluted. Plan to redo?
+ ;; for now ... skip it.
+
+ (thread-sleep! 0.05) ;; delay for startup
+ (let ((legacy-sync (common:run-sync?)))
+ (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
+ (debug-mode (debug:debug-mode 1))
+ (last-time (current-seconds))
+ (no-sync-db (db:open-no-sync-db))
+ (stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct))
+ (sync-duration 0) ;; run time of the sync in milliseconds
+ (subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
+ (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
+ (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
+ (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num)
+
+ (if (and legacy-sync (not *time-to-exit*))
+ (begin
+ (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
+ (let loop ()
+ ;; sync for filesystem local db writes
+ ;;
+ (mutex-lock! *db-multi-sync-mutex*)
+ (let* ((start-file (conc tmp-area "/.start-sync"))
+ (end-file (conc tmp-area "/.end-sync"))
+
+ (need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
+ (sync-in-progress *db-sync-in-progress*)
+ (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
+ (should-sync (and (not *time-to-exit*)
+ (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
+ (start-time (current-seconds))
+ (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
+ (mt-mod-time (file-modification-time mtpath))
+ (last-sync-start (if (common:file-exists? start-file)
+ (file-modification-time start-file)
+ 0))
+ (last-sync-end (if (common:file-exists? end-file)
+ (file-modification-time end-file)
+ 10))
+ (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
+ (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
+ (< mt-mod-time last-sync-start)))
+ (sync-done (<= last-sync-start last-sync-end))
+ (sync-stale (> start-time (+ last-sync-start sync-stale-seconds)))
+ (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting
+ (or need-sync should-sync)
+ (or sync-done sync-stale)
+ (not sync-in-progress)
+ (not recently-synced))))
+ (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress
+ " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
+ " sync-done=" sync-done " sync-period=" sync-period)
+ (if (and (> sync-period 5)
+ (common:low-noise-print 30 "sync-period"))
+ (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
+ ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
+ ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
+ (if will-sync (set! *db-sync-in-progress* #t))
+ (mutex-unlock! *db-multi-sync-mutex*)
+ (if will-sync
+ (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
+ (sync-start (current-milliseconds)))
+ (with-output-to-file start-file (lambda ()(print (current-process-id))))
+
+ ;; put lock here
+
+ ;; (if (or (not max-sync-duration)
+ ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
+
+ ;;
+
+ (for-each
+ (lambda (subdb)
+ (let* (;;(dbstruct (db:setup))
+ (mtdb (dbr:subdb-mtdb subdb))
+ (mtpath (db:dbdat-get-path mtdb))
+ (tmp-area (common:get-db-tmp-area))
+ (res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
+ (set! sync-duration (- (current-milliseconds) sync-start))
+ (if (> res 0) ;; some records were transferred, keep the db alive
+ (begin
+ (mutex-lock! *heartbeat-mutex*)
+ (set! *db-last-access* (current-seconds))
+ (mutex-unlock! *heartbeat-mutex*)
+ (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
+ (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))
+ )
+ subdbs)))
+
+ (if will-sync
+ (begin
+ (mutex-lock! *db-multi-sync-mutex*)
+ (set! *db-sync-in-progress* #f)
+ (set! *db-last-sync* start-time)
+ (with-output-to-file end-file (lambda ()(print (current-process-id))))
+
+ ;; release lock here
+
+ (mutex-unlock! *db-multi-sync-mutex*)))
+ (if (and debug-mode
+ (> (- start-time last-time) 60))
+ (begin
+ (set! last-time start-time)
+ (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
+
+ ;; keep going unless time to exit
+ ;;
+ (if (not *time-to-exit*)
+ (let delay-loop ((count 0))
+ ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
+
+ (if (and (not *time-to-exit*)
+ (< count 6)) ;; was 11, changing to 4.
+ (begin
+ (thread-sleep! 1)
+ (delay-loop (+ count 1))))
+ (if (not *time-to-exit*) (loop))))
+
+;; ;; time to exit, close the no-sync db here
+;; (db:no-sync-close-db no-sync-db stmt-cache)
+ (if (common:low-noise-print 30)
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))
+))
+
+
+(define (std-exit-procedure)
+ ;;(common:telemetry-log-close)
+ (on-exit (lambda () 0))
+ ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
+ (let ((no-hurry (if *time-to-exit* ;; hurry up
+ #f
+ (begin
+ (set! *time-to-exit* #t)
+ #t))))
+ (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
+ (if (and no-hurry (debug:debug-mode 18))
+ (rmt:print-db-stats))
+ (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
+ (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
+ (if *task-db*
+ (let ((db (cdr *task-db*)))
+ (if (sqlite3:database? db)
+ (begin
+ (sqlite3:interrupt! db)
+ (sqlite3:finalize! db #t)
+ ;; (vector-set! *task-db* 0 #f)
+ (set! *task-db* #f)))))
+ (http-client#close-all-connections!)
+ ;; (if (and *runremote*
+ ;; (remote-conndat *runremote*))
+ ;; (begin
+ ;; (http-client#close-all-connections!))) ;; for http-client
+ (if (not (eq? *default-log-port* (current-error-port)))
+ (close-output-port *default-log-port*))
+ (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
+ (th2 (make-thread (lambda ()
+ (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
+ (if no-hurry
+ (begin
+ (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
+ (begin
+ (thread-sleep! 2)))
+ (debug:print 4 *default-log-port* " ... done")
+ )
+ "clean exit")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ )
+ )
+
+ 0)
ADDED dbfile.scm
Index: dbfile.scm
==================================================================
--- /dev/null
+++ dbfile.scm
@@ -0,0 +1,1353 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit dbfile))
+;; (declare (uses debugprint))
+(declare (uses commonmod))
+
+(module dbfile
+ *
+
+ (import scheme
+ chicken
+ data-structures
+ extras
+ matchable)
+
+(import (prefix sqlite3 sqlite3:)
+ posix typed-records srfi-18 srfi-1
+ srfi-69
+ stack
+ files
+ ports
+
+ commonmod
+ )
+
+;; (import debugprint)
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; a single Megatest area with it's multiple dbs is
+;; managed in a dbstruct
+;;
+(defstruct dbr:dbstruct
+ (areapath #f)
+ (homehost #f)
+ (tmppath #f)
+ (read-only #f)
+ (subdbs (make-hash-table))
+ )
+
+;; NOTE: Need one dbr:subdb per main.db, 1.db ...
+;;
+(defstruct dbr:subdb
+ (dbname #f) ;; .megatest/1.db
+ (mtdbfile #f) ;; mtrah/.megatest/1.db
+ (mtdbdat #f) ;; only need one of these for syncing
+ ;; (dbdats (make-hash-table)) ;; id => dbdat
+ (tmpdbfile #f) ;; /tmp/.../.megatest/1.db
+ ;; (refndbfile #f) ;; /tmp/.../.megatest/1.db_ref
+ (dbstack (make-stack)) ;; stack for tmp dbr:dbdat,
+ (homehost #f) ;; not used yet
+ (on-homehost #f) ;; not used yet
+ (read-only #f)
+ (last-sync 0)
+ (last-write (current-seconds))
+ ) ;; goal is to converge on one struct for an area but for now it is too confusing
+
+;; need to keep dbhandles and cached statements together
+(defstruct dbr:dbdat
+ (dbfile #f)
+ (dbh #f)
+ (stmt-cache (make-hash-table))
+ (read-only #f)
+ (birth-sec (current-seconds)))
+
+(define *dbstruct-dbs* #f)
+(define *db-open-mutex* (make-mutex))
+(define *db-access-mutex* (make-mutex)) ;; used in common.scm
+(define *no-sync-db* #f)
+(define *db-sync-in-progress* #f)
+(define *db-with-db-mutex* (make-mutex))
+(define *max-api-process-requests* 0)
+(define *api-process-request-count* 0)
+(define *db-write-access* #t)
+(define *db-last-sync* 0) ;; last time the sync to megatest.db happened
+(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
+
+(define (db:generic-error-printout exn . message)
+ (print-call-chain (current-error-port))
+ (apply dbfile:print-err message)
+ (dbfile:print-err
+ ", error: " ((condition-property-accessor 'exn 'message) exn)
+ ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
+ ", location: " ((condition-property-accessor 'exn 'location) exn)
+ ))
+
+(define (dbfile:run-id->key run-id)
+ (or run-id 'main))
+
+(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
+ (if (<= try-num 0)
+ #f
+ (handle-exceptions
+ exn
+ (begin
+ (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
+ (thread-sleep! 3)
+ (sqlite3:interrupt! db)
+ (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
+ (if (sqlite3:database? db)
+ (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
+ (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
+ (sqlite3:finalize! db)
+ #t)
+ (begin
+ (dbfile:print-err "db:safely-close-sqlite3-db: " db " is not an sqlite3 db")
+ #f
+ )
+ ))))
+
+;; close all opened run-id dbs
+(define (db:close-all dbstruct)
+ (if (dbr:dbstruct? dbstruct)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
+;; (print-call-chain *default-log-port*))
+ ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
+ (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
+ (for-each
+ (lambda (subdb)
+ (let* ((tdbs (stack->list (dbr:subdb-dbstack subdb)))
+ (mtdbdat (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb)))
+ #;(rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb))))
+
+ (map (lambda (dbdat)
+ (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat))
+ (dbh (dbr:dbdat-dbh dbdat)))
+ (db:safely-close-sqlite3-db dbh stmt-cache)))
+ tdbs)
+ (db:safely-close-sqlite3-db mtdbdat (dbr:dbdat-stmt-cache (dbr:subdb-mtdbdat subdb)))
+ ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
+ #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+ subdbs)
+ #t
+ )
+ #f
+ )
+)
+
+;; ;; set up a single db (e.g. main.db, 1.db ... etc.)
+;; ;;
+;; (define (db:setup-db dbstruct areapath run-id)
+;; (let* ((dbname (db:run-id->dbname run-id))
+;; (dbstruct (hash-table-ref/default dbstructs dbname #f)))
+;; (if dbstruct
+;; dbstruct
+;; (let* ((dbstruct-new (make-dbr:dbstruct)))
+;; (db:open-db dbstruct-new run-id areapath: areapath do-sync: #t)
+;; (hash-table-set! dbstructs dbname dbstruct-new)
+;; dbstruct-new))))
+
+;; ; Returns the dbdat for a particular dbfile inside the area
+;; ;;
+;; (define (dbr:dbstruct-get-dbdat dbstruct dbfile)
+;; (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))
+;;
+;; (define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
+;; (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))
+;;
+;; (define (db:run-id->first-num run-id)
+;; (let* ((s (number->string run-id))
+;; (l (string-length s)))
+;; (substring s (- l 1) l)))
+
+;; 1234 => 4/1234.db
+;; #f => 0/main.db
+;; (abandoned the idea of num/db)
+;;
+(define (dbfile:run-id->path apath run-id)
+ (conc apath"/"(dbfile:run-id->dbname run-id)))
+
+(define (db:dbname->path apath dbname)
+ (conc apath"/"dbname))
+
+;; POTENTIAL BUG: this implementation could produce a db file if run-id is neither #f or a number
+(define (dbfile:run-id->dbname run-id)
+ (cond
+ ((number? run-id) (conc ".megatest/" (modulo run-id 100) ".db"))
+ ((not run-id) (conc ".megatest/main.db"))
+ (else run-id)))
+
+;; 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 (dbfile:setup do-sync areapath tmppath)
+ (cond
+ (*dbstruct-dbs*
+ (dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized")
+ *dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard
+ (else
+ (let* ((dbstruct (make-dbr:dbstruct)))
+ (set! *dbstruct-dbs* dbstruct)
+ (dbr:dbstruct-areapath-set! dbstruct areapath)
+ (dbr:dbstruct-tmppath-set! dbstruct tmppath)
+ dbstruct))))
+
+(define (dbfile:get-subdb dbstruct run-id)
+ (let* ((dbfname (dbfile:run-id->dbname run-id)))
+ (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f)))
+
+(define (dbfile:set-subdb dbstruct run-id subdb)
+ (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb))
+
+(define *dbfile:num-handles-in-use* 0)
+
+;; Get/open a database
+;; if run-id => get run specific db
+;; if #f => get main db
+;; if run-id is a string treat it as a filename
+;; 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 (dbfile:get-dbdat dbstruct run-id)
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+ (if (stack-empty? (dbr:subdb-dbstack subdb))
+ #f
+ (begin
+ (set! *dbfile:num-handles-in-use* (+ *dbfile:num-handles-in-use* 1))
+ (stack-pop! (dbr:subdb-dbstack subdb))))))
+
+;; return a previously opened db handle to the stack of available handles
+(define (dbfile:add-dbdat dbstruct run-id dbdat)
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+ (set! *dbfile:num-handles-in-use* (- *dbfile:num-handles-in-use* 1))
+ (stack-push! (dbr:subdb-dbstack subdb) dbdat)))
+
+;; set up a subdb
+;;
+(define (dbfile:init-subdb dbstruct run-id init-proc)
+ (let* ((dbname (dbfile:run-id->dbname run-id))
+ (areapath (dbr:dbstruct-areapath dbstruct))
+ (tmppath (dbr:dbstruct-tmppath dbstruct))
+ (mtdbpath (dbfile:run-id->path areapath run-id))
+ (tmpdbpath (dbfile:run-id->path tmppath run-id))
+ (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc))
+ (newsubdb (make-dbr:subdb dbname: dbname
+ mtdbfile: mtdbpath
+ tmpdbfile: tmpdbpath
+ mtdbdat: mtdbdat)))
+ (dbfile:set-subdb dbstruct run-id newsubdb)
+ newsubdb)) ;; return the new subdb - but shouldn't really use it
+
+;; returns dbdat with dbh and dbfilepath
+;;
+;; NOTE: the handle is on /tmp db file!
+;;
+;; 1. if needed setup the subdb for the given run-id
+;; 2. if there is no existing db handle in the stack
+;; create a new handle and return it (do NOT add
+;; it to the stack).
+;;
+(define (dbfile:open-db dbstruct run-id init-proc)
+ (if (> *dbfile:num-handles-in-use* 10)
+ (let* ((wait-delay (- *dbfile:num-handles-in-use* 9)))
+ (dbfile:print-err "INFO: over ten dbfile handle threads in use ("*dbfile:num-handles-in-use*") delaying "wait-delay" second")
+ (thread-sleep! wait-delay)))
+
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+ (if (not subdb) ;; not yet defined
+ (begin
+ (dbfile:init-subdb dbstruct run-id init-proc)
+ (dbfile:open-db dbstruct run-id init-proc))
+ (let* ((dbdat (dbfile:get-dbdat dbstruct run-id)))
+ (if dbdat
+ dbdat
+ (let* ((tmppath (dbr:dbstruct-tmppath dbstruct))
+ (tmpdbpath (dbfile:run-id->path tmppath run-id)))
+ (dbfile:open-sqlite3-db tmpdbpath init-proc)))))))
+
+;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open
+;;
+
+;; this stuff is for initial debugging, please remove it when
+;; this code stabilizes
+(define *dbopens* (make-hash-table))
+(define (dbfile:inc-db-open dbfile)
+ (let* ((curr-opens-count (+ (hash-table-ref/default *dbopens* dbfile 0) 1)))
+ ;; (if (> curr-opens-count 1) ;; this should NOT be happening
+ ;; (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!"))
+ (hash-table-set! *dbopens* dbfile curr-opens-count)
+ curr-opens-count))
+
+;; Open the classic megatest.db file (defaults to open in toppath)
+;;
+;; NOTE: returns a dbdat not a dbstruct!
+;;
+(define (dbfile:open-sqlite3-db dbpath init-proc)
+ (let* ((dbexists (file-exists? dbpath))
+ (write-access (file-write-access? dbpath))
+ (db (dbfile:cautious-open-database dbpath init-proc))) #;(sqlite3:open-database dbpath)
+ (dbfile:inc-db-open dbpath)
+ ;; (init-proc db)
+ (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
+
+(define (dbfile:print-and-exit . params)
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (apply print params)))
+ (exit 1))
+
+(define (dbfile:print-err . params)
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (apply print params))))
+
+;; 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 (dbfile: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 (file-exists? fname))
+ (file-write (if file-exists
+ (file-write-access? fname)
+ dir-writable )))
+ ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
+ (if file-write ;; dir-writable
+ (condition-case
+ (let* ((lockfname (conc fname ".lock"))
+ (readyfname (conc parent-dir "/.ready-" raw-fname))
+ (readyexists (common:file-exists? readyfname)))
+ (if (not readyexists)
+ (common:simple-file-lock-and-wait lockfname))
+ (let ((db (sqlite3:open-database fname)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not file-exists)
+ (initproc db))
+ (if (not readyexists)
+ (begin
+ (common:simple-file-release-lock lockfname)
+ (with-output-to-file
+ readyfname
+ (lambda ()
+ (print "Ready at "
+ (seconds->year-work-week/day-time
+ (current-seconds)))))))
+ db))
+ (exn (io-error) (dbfile:print-and-exit "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt) (dbfile:print-and-exit "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy) (dbfile:print-and-exit "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
+ (exn (permission)(dbfile:print-and-exit "ERROR: database " fname " has some permissions problem."))
+ (exn () (dbfile:print-and-exit "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
+
+ (condition-case
+ (begin
+ (dbfile:print-err "WARNING: opening db in non-writable dir " fname)
+ (let ((db (sqlite3:open-database fname)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ ;; (mutex-unlock! *db-open-mutex*)
+ db))
+ (exn (io-error)
+ (dbfile:print-and-exit
+ "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt)
+ (dbfile:print-and-exit
+ "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy)
+ (dbfile:print-and-exit
+ "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
+ (exn (permission)
+ (dbfile:print-and-exit
+ "ERROR: database " fname " has some permissions problem."))
+ (exn ()
+ (dbfile:print-and-exit
+ "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:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t))
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id))
+ (tmpdb-stack (dbr:subdb-dbstack subdb))
+ (max-stale-tmp (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
+ (dbpath (dbr:dbstruct-tmppath dbstruct)) ;; (db:dbfile-path)) ;; path to tmp db area
+ (dbname (dbfile:run-id->dbname run-id))
+ (dbexists (file-exists? dbpath))
+ (areapath (dbr:dbstruct-areapath dbstruct))
+ (mtdbfname (conc areapath "/"dbname))
+ (mtdbexists (file-exists? mtdbfname))
+ (mtdbmodtime (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname) #f))
+ (mtdb (db:open-sqlite-db mtdbfname init-proc))
+ ;; the reference db for syncing
+ (refdbfname (conc dbpath "/"dbname"_ref"))
+ (refndb (db:open-megatest-db refdbfname))
+ ;; (mtdbpath (dbr:dbdat-dbfile mtdb))
+ ;; the tmpdb
+ (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.megatest/[main|1,2...].db
+ (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
+ (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
+ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
+
+ (write-access (file-write-access? mtdbfname))
+
+ ;; (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))))
+
+ (when write-access
+ (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
+ (sqlite3:execute (dbr:dbdat-dbh 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:subdb-read-only-set! subdb #t)))
+ (dbr:subdb-mtdb-set! subdb mtdb)
+ (dbr:subdb-tmpdb-set! subdb tmpdb)
+ (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
+ (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
+ (dbr:subdb-refndb-set! subdb refndb)
+ (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
+ (dbfile:print-err "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
+ (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb)
+ ;; touch tmp db to avoid wal mode wierdness
+ (set! (file-modification-time tmpdbfname) (current-seconds))
+ (dbfile:print-err "INFO: db:sync-all-tables-list done.")
+ )
+ (dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
+ ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
+ tmpdb))
+
+
+(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 500))
+
+ (let* ((busy-file (conc fname"-journal"))
+ (delay-time (* (- 51 tries-left) 1.1))
+ (write-access (file-write-access? fname))
+ (dir-access (file-write-access? (pathname-directory fname)))
+ (retry (lambda ()
+ (thread-sleep! delay-time)
+ (if (> tries-left 0)
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
+ (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
+
+ (if (and (file-write-access? fname)
+ (file-exists? busy-file))
+ (begin
+ (if (common:low-noise-print 120 busy-file)
+ (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file "
+ busy-file" exists, trying again in few seconds."))
+ (thread-sleep! 1)
+ (if (eq? tries-left 2)
+ (begin
+ (dbfile:print-err "INFO: forcing journal rollup "busy-file)
+ (dbfile:brute-force-salvage-db fname)))
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1)))
+
+ (let* ((result (condition-case
+ (if dir-access
+ (dbfile:with-simple-file-lock
+ (conc fname ".lock")
+ (lambda ()
+ (let* ((db-exists (file-exists? fname))
+ (db (sqlite3:open-database fname))) ;; creates an empty db if it did not already exist.
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000))
+ (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
+ (if (and init-proc (not db-exists))
+ (init-proc db))
+ db)))
+ (begin
+ (if (file-exists? fname )
+ (begin
+ (sqlite3:open-database fname)
+ )
+ (print "file doesn't exist: " fname)
+ )
+ )
+ )
+ (exn (io-error)
+ (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
+ (retry))
+ (exn (corrupt)
+ (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
+ (retry))
+ (exn (busy)
+ (dbfile:print-err exn "ERROR: database " fname
+ " is locked. Try copying to another location, remove original and copy back.")
+ (retry))
+ (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
+ (retry))
+ (exn ()
+ (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
+ ((condition-property-accessor 'exn 'message) exn))
+ (retry)))))
+ result))))
+
+(define (dbfile:brute-force-salvage-db fname)
+ (let* ((backupfname (conc fname"-"(current-process-id)".bak"))
+ (cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;")
+ "cp "backupfname" "fname)))
+ (dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n"
+ " "cmd)
+ (system cmd)))
+
+#;(define (dbfile:cautious-open-database-orig fname init-proc #!optional (tries-left 50))
+ (let* ((lock-file (conc fname".lock"))
+ (delay-time (* (- 51 tries-left) 1.1))
+ (retry (lambda ()
+ (thread-sleep! delay-time)
+ (if (> tries-left 0)
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
+ (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
+ (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file expire-time: 3)))
+ (begin
+ (dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in few seconds.")
+ (thread-sleep! 1)
+ (if (eq? tries-left 2)
+ (begin
+ (dbfile:print-err "INFO: stealing the lock "lock-file)
+ (delete-file* lock-file)))
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1)))
+ (let* ((db-exists (file-exists? fname))
+ (result (condition-case
+ (let* ((db (sqlite3:open-database fname)))
+ (if (and init-proc (not db-exists))
+ (init-proc db))
+ db)
+ (exn (io-error)
+ (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
+ (retry))
+ (exn (corrupt)
+ (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
+ (retry))
+ (exn (busy)
+ (dbfile:print-err exn "ERROR: database " fname
+ " is locked. Try copying to another location, remove original and copy back.")
+ (retry))
+ (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
+ (retry))
+ (exn ()
+ (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
+ ((condition-property-accessor 'exn 'message) exn))
+ (retry)))))
+ (if (file-write-access? fname)
+ (dbfile:simple-file-release-lock lock-file)
+ )
+ result))))
+
+
+(define (dbfile:open-no-sync-db dbpath)
+ (if *no-sync-db*
+ *no-sync-db*
+ (begin
+ (if (not (file-exists? dbpath))
+ (create-directory dbpath #t))
+ (let* ((dbname (conc dbpath "/no-sync.db"))
+ (db-exists (file-exists? dbname))
+ (init-proc (lambda (db)
+ (if (not db-exists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));"))
+ )))
+ (db (dbfile:cautious-open-database dbname init-proc))) ;; (sqlite3:open-database dbname)))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (set! *no-sync-db* db)
+ db))))
+
+(define (db:no-sync-set db var val)
+ (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
+
+(define (db:no-sync-del! db var)
+ (sqlite3:execute db "DELETE FROM no_sync_metadat WHERE var=?;" var))
+
+(define (db:no-sync-get/default db var default)
+ (let ((res default))
+ (sqlite3:for-each-row
+ (lambda (val)
+ (set! res val))
+ db
+ "SELECT val FROM no_sync_metadat WHERE var=?;"
+ var)
+ (if res
+ (let ((newres (if (string? res)
+ (string->number res)
+ #f)))
+ (if newres
+ newres
+ res))
+ res)))
+
+;; transaction protected lock aquisition
+;; either:
+;; fails returns (#f . lock-creation-time)
+;; succeeds (returns (#t . lock-creation-time)
+;; use (db:no-sync-del! db keyname) to release the lock
+;;
+(define (db:no-sync-get-lock db keyname)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (condition-case
+ (let* ((curr-val (db:no-sync-get/default db keyname #f)))
+ (if curr-val
+ `(#f . ,curr-val) ;; (sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))
+ (let ((lock-time (current-seconds)))
+ (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
+ `(#t . ,lock-time))))
+ (exn (io-error) (dbfile:print-err "ERROR: i/o error with no-sync db. Check permissions, disk space etc. and try again."))
+ (exn (corrupt) (dbfile:print-err "ERROR: database no-sync db is corrupt. Repair it to proceed."))
+ (exn (busy) (dbfile:print-err "ERROR: database no-sync db is locked. Try copying to another location, remove original and copy back."))
+ (exn (permission)(dbfile:print-err "ERROR: database no-sync db has some permissions problem."))
+ (exn () ;; (status done) ;; I don't know how to detect status done but no data!
+ (dbfile:print-err "ERROR: Unknown error with database no-sync db message: exn="(condition->list exn)", \n"
+ ((condition-property-accessor 'exn 'message) exn))
+ `(#f . ,(current-seconds)))))))
+
+(define (db:no-sync-get-lock-timeout db keyname timeout)
+ (let* ((lockdat (db:no-sync-get-lock db keyname)))
+ (match lockdat
+ ((#f . lock-time)
+ (if (> (- (current-seconds) (if (string? lock-time)(string->number lock-time)lock-time)) timeout)
+ (let ((lock-time (current-seconds)))
+ ;; (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn)
+ (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
+ `(#t . ,lock-time))
+ lockdat))
+ (else lockdat))))
+
+;; NOTE: This will steal the lock after timeout of waiting.
+;;
+(define (db:with-no-sync-lock db keyname timeout proc)
+ (let* ((lockdat (db:no-sync-get-lock-timeout db keyname))
+ (gotlock (car lockdat))
+ (locktime (cdr lockdat)))
+ (if gotlock
+ (let ((res (proc)))
+ (db:no-sync-del! db keyname)
+ res))))
+
+;;======================================================================
+;; sync back functions pulled from db.scm
+;;======================================================================
+
+;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f
+;;
+(define (db:lock-and-delta-sync no-sync-db dbstruct from-db-file runid keys dbinit)
+ (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
+ ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync")
+ (let* ((lock-file (conc from-db-file ".lock")))
+ (if (common:simple-file-lock lock-file)
+ (begin
+ (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds))
+ (set! *db-sync-in-progress* #t)
+ (db:sync-touched dbstruct runid keys dbinit)
+ (set! *db-sync-in-progress* #f)
+ (delete-file* lock-file)
+ #t)
+ (begin
+ (dbfile:print-err "INFO: could not get lock for " from-db-file ", sync likely in progress.")
+ #f
+ ))))
+
+;; ;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f
+;; ;;
+;; (define (db:lock-and-delta-sync-orig no-sync-db dbstruct from-db-file runid keys dbinit)
+;; (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
+;; ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync")
+;; (let* ((lockdat (db:no-sync-get-lock-timeout no-sync-db from-db-file 60))
+;; (gotlock (car lockdat))
+;; (locktime (cdr lockdat)))
+;; ;; (debug:print-info 3 *default-log-port* "db:lock-and-delta-sync: got lock?")
+;;
+;; (if gotlock
+;; (begin
+;; (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds))
+;; (set! *db-sync-in-progress* #t)
+;; (db:sync-touched dbstruct runid keys dbinit)
+;; (set! *db-sync-in-progress* #f)
+;; (db:no-sync-del! no-sync-db from-db-file)
+;; #t)
+;; (begin
+;; (dbfile:print-err "ERROR: could not get lock for " from-db-file " from no-sync-db")
+;; #f
+;; ))))
+
+;; sync run from tmp disk to nfs disk if touched
+;;
+;; call with dbinit=db:initialize-main-db
+;;
+(define (db:sync-touched dbstruct run-id keys #!key dbinit (force-sync #f))
+ (dbfile:print-err "db:sync-touched Syncing: " (conc (if run-id run-id "main") ".db"))
+ (let* (;; the subdb is needed to access the mtdbdat
+ (subdb (or (dbfile:get-subdb dbstruct run-id)
+ (dbfile:init-subdb dbstruct run-id dbinit)))
+ (tmpdbfile (dbr:subdb-tmpdbfile subdb))
+ (mtdb (dbr:subdb-mtdbdat subdb))
+ (tmpdb (db:open-db dbstruct run-id dbinit)) ;; sqlite3-db tmpdbfile #f))
+ (start-t (current-seconds)))
+ (mutex-lock! *db-multi-sync-mutex*)
+ (let ((update_info (cons "last_update" (if force-sync 0 *db-last-sync*) )))
+ (mutex-unlock! *db-multi-sync-mutex*)
+ (db:sync-tables (db:sync-all-tables-list dbstruct keys) update_info tmpdb mtdb))
+ (mutex-lock! *db-multi-sync-mutex*)
+ (set! *db-last-sync* start-t)
+ (set! *db-last-access* start-t)
+ (mutex-unlock! *db-multi-sync-mutex*)
+ (dbfile:add-dbdat dbstruct run-id tmpdb)
+ #t))
+
+;; 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 keys)
+ (let ((keys 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 "archive_disks"
+ '("id" #f)
+ '("archive_area_name" #f)
+ '("disk_path" #f)
+ '("last_df" #f)
+ '("last_df_time" #f)
+ '("creation_time" #f))
+
+ (list "archive_blocks"
+ '("id" #f)
+ '("archive_disk_id" #f)
+ '("disk_path" #f)
+ '("last_du" #f)
+ '("last_du_time" #f)
+ '("creation_time" #f))
+
+ (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 keys)
+ (append (db:sync-main-list dbstruct keys)
+ db:sync-tests-only))
+
+;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
+;; db's are dbdat's
+;;
+;; if last-update specified ("field-name" . time-in-seconds)
+;; then sync only records where field-name >= time-in-seconds
+;; IFF field-name exists
+;;
+(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
+ (handle-exceptions
+ exn
+ (begin
+ (dbfile:print-err "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
+ (print-call-chain (current-error-port))
+ (dbfile:print-err " message: " ((condition-property-accessor 'exn 'message) exn))
+ (dbfile:print-err "exn=" (condition->list exn))
+ (dbfile:print-err " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+ (dbfile:print-err " src db: " (dbr:dbdat-dbfile fromdb))
+ (for-each (lambda (dbdat)
+ (let ((dbpath (dbr:dbdat-dbfile dbdat)))
+ (dbfile:print-err " dbpath: " dbpath)
+ (if #t ;; (not (db:repair-db dbdat))
+ (begin
+ (dbfile:print-err "Failed to rebuild (repair is turned off) " dbpath ", exiting now.")
+ (exit)))))
+ (cons todb slave-dbs))
+
+ 0)
+
+ ;; this is the work to be done")
+ (cond
+ ((not fromdb) (dbfile:print-err "WARNING: db:sync-tables called with fromdb missing")
+ -1)
+ ((not todb) (dbfile:print-err "WARNING: db:sync-tables called with todb missing")
+ -2)
+ ((not (sqlite3:database? (dbr:dbdat-dbh fromdb)))
+ (dbfile:print-err "db:sync-tables called with fromdb not a database " fromdb)
+ -3)
+ ((not (sqlite3:database? (dbr:dbdat-dbh todb)))
+ (dbfile:print-err "db:sync-tables called with todb not a database " todb)
+ -4)
+
+ ((not (file-write-access? (dbr:dbdat-dbfile todb)))
+ (dbfile:print-err "db:sync-tables called with todb not a read-only database " todb)
+ -5)
+ ((not (null? (let ((readonly-slave-dbs
+ (filter
+ (lambda (dbdat)
+ (not (file-write-access? (dbr:dbdat-dbfile todb))))
+ slave-dbs)))
+ (for-each
+ (lambda (bad-dbdat)
+ (dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat))
+ readonly-slave-dbs)
+ readonly-slave-dbs))) -6)
+ (else
+ ;; (dbfile:print-err "db:sync-tables: args are good")
+
+ (let ((stmts (make-hash-table)) ;; table-field => stmt
+ (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
+ (numrecs (make-hash-table))
+ (start-time (current-milliseconds))
+ (tot-count 0))
+ (for-each ;; table
+ (lambda (tabledat)
+ (let* ((tablename (car tabledat))
+ (fields (cdr tabledat))
+ (has-last-update (member "last_update" fields))
+ (use-last-update (cond
+ ((and has-last-update
+ (member "last_update" fields))
+ #t) ;; if given a number, just use it for all fields
+ ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
+ ((and (pair? last-update)
+ (member (car last-update) ;; last-update field name
+ (map car fields)))
+ #t)
+ ((and last-update (not (pair? last-update)) (not (number? last-update)))
+ (dbfile:print-err "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
+ #f)
+ (else
+ #f)))
+ (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
+ (if (number? last-update)
+ last-update
+ (cdr last-update))
+ #f))
+ (last-update-field (if use-last-update
+ (if (number? last-update)
+ "last_update"
+ (car last-update))
+ #f))
+ (num-fields (length fields))
+ (field->num (make-hash-table))
+ (num->field (apply vector (map car fields))) ;; BBHERE
+ (full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
+ " FROM " tablename (if use-last-update ;; apply last-update criteria
+ (conc " WHERE " last-update-field " >= " last-update-value)
+ "")
+ ";"))
+ (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
+ " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
+ (fromdat '())
+ (fromdats '())
+ (totrecords 0)
+ (batch-len 100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
+ (todat (make-hash-table))
+ (count 0)
+ (field-names (map car fields))
+ (delay-handicap 0) ;; (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
+ )
+
+ ;; set up the field->num table
+ (for-each
+ (lambda (field)
+ (hash-table-set! field->num field count)
+ (set! count (+ count 1)))
+ fields)
+
+ ;; read the source table
+ ;; store a list of all rows in the table in fromdat, up to batch-len.
+ ;; Then add fromdat to the fromdats list, clear fromdat and repeat.
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! fromdat (cons (apply vector a b) fromdat))
+ (if (> (length fromdat) batch-len)
+ (begin
+ (set! fromdats (cons fromdat fromdats))
+ (set! fromdat '())
+ (set! totrecords (+ totrecords 1)))
+ )
+ )
+ (dbr:dbdat-dbh fromdb)
+ full-sel)
+
+ ;; Count less than batch-len as a record
+ (if (> (length fromdat) 0)
+ (set! totrecords (+ totrecords 1)))
+
+ ;; tack on remaining records in fromdat
+ (if (not (null? fromdat))
+ (set! fromdats (cons fromdat fromdats)))
+
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (hash-table-set! todat a (apply vector a b)))
+ (dbr:dbdat-dbh todb)
+ full-sel)
+
+ (when (and delay-handicap (> delay-handicap 0))
+ (dbfile:print-err "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
+ (thread-sleep! delay-handicap)
+ (dbfile:print-err "synthetic sync delay of "delay-handicap" seconds completed")
+ )
+
+ ;; first pass implementation, just insert all changed rows
+
+ (for-each
+ (lambda (targdb)
+ (let* ((db (dbr:dbdat-dbh targdb))
+ (drp-trigger (if (member "last_update" field-names)
+ (db:drop-trigger db tablename)
+ #f))
+ (has-last-update (member "last_update" field-names))
+ (is-trigger-dropped (if has-last-update
+ (db:is-trigger-dropped db tablename)
+ #f))
+ (stmth (sqlite3:prepare db full-ins))
+ (changed-rows 0))
+ (for-each
+ (lambda (fromdat-lst)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each ;;
+ (lambda (fromrow)
+ (let* ((a (vector-ref fromrow 0))
+ (curr (hash-table-ref/default todat a #f))
+ (same #t))
+ (let loop ((i 0))
+ (if (or (not curr)
+ (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
+ (set! same #f))
+ (if (and same
+ (< i (- num-fields 1)))
+ (loop (+ i 1))))
+ (if (not same)
+ (begin
+ (apply sqlite3:execute stmth (vector->list fromrow))
+ (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))
+ (set! changed-rows (+ changed-rows 1))
+ )
+ )
+ ))
+ fromdat-lst))))
+ fromdats)
+
+ (sqlite3:finalize! stmth)
+ (if (member "last_update" field-names)
+ (db:create-trigger db tablename))))
+ (append (list todb) slave-dbs)
+ )
+ )
+ )
+ tbls)
+ (let* ((runtime (- (current-milliseconds) start-time))
+ (should-print (or ;; (debug:debug-mode 12)
+ (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
+ (for-each
+ (lambda (dat)
+ (let ((tblname (car dat))
+ (count (cdr dat)))
+ (set! tot-count (+ tot-count count))
+ ))
+ (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
+ tot-count)))))
+
+;;======================================================================
+;; trigger setup/takedown
+;;======================================================================
+
+(define db:trigger-list
+ (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+ FOR EACH ROW
+ BEGIN
+ UPDATE runs SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ FOR EACH ROW
+ BEGIN
+ UPDATE run_stats SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ FOR EACH ROW
+ BEGIN
+ UPDATE tests SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_steps SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_data SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )))
+;;
+;; ADD run-id SUPPORT
+;;
+(define (db:create-all-triggers dbstruct)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (db:create-triggers db))))
+
+(define (db:create-triggers db)
+ (for-each (lambda (key)
+ (sqlite3:execute db (cadr key)))
+ db:trigger-list))
+
+(define (db:drop-all-triggers dbstruct)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (db:drop-triggers db))))
+
+(define (db:is-trigger-dropped db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger")))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (name)
+ (if (equal? name trigger-name)
+ (set! res #t)))
+ db
+ "SELECT name FROM sqlite_master WHERE type = 'trigger' ;")
+ res))
+
+(define (db:drop-triggers db)
+ (for-each
+ (lambda (key)
+ (sqlite3:execute db (conc "drop trigger if exists " (car key))))
+ db:trigger-list))
+
+(define (db:drop-trigger db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (for-each
+ (lambda (key)
+ (if (equal? (car key) trigger-name)
+ (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
+ db:trigger-list)))
+
+(define (db:create-trigger db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (for-each (lambda (key)
+ (if (equal? (car key) trigger-name)
+ (sqlite3:execute db (cadr key))))
+ db:trigger-list)))
+
+;;======================================================================
+;; db access stuff
+;;======================================================================
+
+;; call with dbinit=db:initialize-main-db
+;;
+(define (db:open-db dbstruct run-id dbinit)
+ (mutex-lock! *db-open-mutex*)
+ (let* ((dbdat (dbfile:open-db dbstruct run-id dbinit)))
+ (set! *db-write-access* (not (dbr:dbdat-read-only dbdat)))
+ (mutex-unlock! *db-open-mutex*)
+ dbdat))
+
+(define dbfile:db-init-proc (make-parameter #f))
+
+;; (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:open-db dbstruct run-id (dbfile:db-init-proc)) ;; (dbfile: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"))
+ (jfile (conc fname"-journal"))
+ #;(subdb (if have-struct
+ (dbfile:get-subdb dbstruct run-id)
+ #f))
+ (use-mutex (> *api-process-request-count* 25))) ;; was 25
+ (if (file-exists? jfile)
+ (begin
+ (dbfile:print-err "INFO: "jfile" exists, delaying few seconds to reduce database load")
+ (thread-sleep! 2)))
+ (if (and use-mutex
+ (common:low-noise-print 120 "over-50-parallel-api-requests"))
+ (dbfile:print-err *api-process-request-count* " parallel api requests being processed in process "
+ (current-process-id) ", throttling access"))
+ (condition-case
+ (begin
+ (if use-mutex (mutex-lock! *db-with-db-mutex*))
+ (let ((res (apply proc dbdat db params))) ;; the actual call is here.
+ (if use-mutex (mutex-unlock! *db-with-db-mutex*))
+ ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
+ (if dbdat
+ (dbfile:add-dbdat dbstruct run-id dbdat))
+ res))
+ (exn (io-error)
+ (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt)
+ (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy)
+ (db:generic-error-printout exn "ERROR: database " fname
+ " is locked. Try copying to another location, remove original and copy back."))
+ (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
+ (exn ()
+ (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
+ ((condition-property-accessor 'exn 'message) exn))))))
+
+;;======================================================================
+;; another attempt at a transactionized queue
+;;======================================================================
+
+;; ;; ;; (define *transaction-queues* (make-hash-table))
+;; ;; ;;
+;; ;; ;; (define (db:get-queue run-id)
+;; ;; ;; (let* ((res (hash-table-ref/default *transaction-queues* run-id #f)))
+;; ;; ;; (if res
+;; ;; ;; res
+;; ;; ;; (let* ((newq (make-queue)))
+;; ;; ;; (hash-table-set! *transaction-queues* run-id newq)
+;; ;; ;; newq))))
+;; ;; ;;
+;; ;; ;; (define (db:add-to-transaction-queue dbstruct proc params)
+;; ;; ;; (let* ((mbox (make-mailbox))
+;; ;; ;; (q (db:get-queue run-id)))
+;; ;; ;; (queue-add! *transaction-queue* (list dbstruct proc mbox))
+;; ;; ;; (mailbox-receive mbox)))
+;; ;; ;;
+;; ;; ;; (define (db:process-transaction-queue *dbstruct-dbs*)
+;; ;; ;; (for-each
+;; ;; ;; (lambda (run-id)
+;; ;; ;; (let* ((q (hash-table-ref *transaction-queue* run-id)))
+;; ;; ;; ;; with-transaction
+;; ;; ;; ;; dbstruct
+;; ;; ;; ;; pop items from queue and execute them, return results via mailbox
+;; ;; ;; q
+;; ;; ;; ;; pop
+;; ;; ;; ))
+;; ;; ;; (hash-table-keys *transaction-queues*)))
+
+;;======================================================================
+;; file utils
+;;======================================================================
+
+;;======================================================================
+;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
+;;
+(define (dbfile:lazy-modification-time fpath)
+ (handle-exceptions
+ exn
+ (begin
+ (dbfile:print-err "Failed to get modification time for " fpath ", treating it as zero. exn=" exn)
+ 0)
+ (if (file-exists? fpath)
+ (file-modification-time fpath)
+ 0)))
+
+;;======================================================================
+;; find timestamp of newest file associated with a sqlite db file
+(define (dbfile:lazy-sqlite-db-modification-time fpath)
+ (let* ((glob-list (handle-exceptions
+ exn
+ (begin
+ (dbfile:print-err "Failed to glob " fpath "*, exn=" exn)
+ `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))))
+ (glob (conc fpath "*"))))
+ (file-list (if (eq? 0 (length glob-list))
+ '("/no/such/file")
+ glob-list)))
+ (apply max
+ (map
+ dbfile:lazy-modification-time
+ file-list))))
+
+;; dot-locking egg seems not to work, using this for now
+;; if lock is older than expire-time then remove it and try again
+;; to get the lock
+;;
+(define (dbfile:simple-file-lock fname #!key (expire-time 300))
+ (let ((fmod-time (handle-exceptions
+ ext
+ (current-seconds)
+ (file-modification-time fname))))
+ (if (file-exists? fname)
+ (if (> (- (current-seconds) fmod-time) expire-time)
+ (begin
+ (handle-exceptions exn #f (delete-file* fname))
+ (dbfile:simple-file-lock fname expire-time: expire-time))
+ #f)
+ (let ((key-string (conc (get-host-name) "-" (current-process-id)))
+ (oup (open-output-file fname)))
+ (with-output-to-port
+ oup
+ (lambda ()
+ (print key-string)))
+ (close-output-port oup)
+ #;(with-output-to-file fname ;; bizarre. with-output-to-file does not seem to be cleaning up after itself.
+ (lambda ()
+ (print key-string)))
+ (thread-sleep! 0.25)
+ (if (file-exists? fname)
+ (handle-exceptions exn
+ #f
+ (with-input-from-file fname
+ (lambda ()
+ (equal? key-string (read-line)))))
+ #f)
+ )
+ )
+ )
+)
+
+(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
+ (let ((end-time (+ expire-time (current-seconds))))
+ (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time)))
+ (if got-lock
+ #t
+ (if (> end-time (current-seconds))
+ (begin
+ (thread-sleep! 3)
+ (loop (dbfile:simple-file-lock fname expire-time: expire-time)))
+ #f)))))
+
+(define (dbfile:simple-file-release-lock fname)
+ (handle-exceptions
+ exn
+ #f ;; I don't really care why this failed (at least for now)
+ (delete-file* fname)))
+
+(define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300))
+ (let ((gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time)))
+ (if gotlock
+ (let ((res (proc)))
+ (dbfile:simple-file-release-lock fname)
+ res)
+ (assert #t "FATAL: simple file lock never got a lock."))))
+
+)
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -31,7 +31,26 @@
(define (db:run-id->dbname run-id)
(cond
((number? run-id)(conc run-id ".db"))
((not run-id) "main.db")
(else run-id)))
-
+
+
+;;======================================================================
+;; 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))))
+
)
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -528,11 +528,14 @@
(common:without-vars
command
"MT_.*"))
(message-window (conc "Directory " rundir " not found"))))))
(xterm)
- (print "Adding xterm code")))))
+ )
+ )
+ )
+)
;;======================================================================
;; D A T A T A B L E S
;;======================================================================
ADDED debugprint.scm
Index: debugprint.scm
==================================================================
--- /dev/null
+++ debugprint.scm
@@ -0,0 +1,175 @@
+
+(declare (unit debugprint))
+(declare (uses mtargs))
+
+(module debugprint
+ *
+
+;;(import scheme chicken data-structures extras files ports)
+ (import
+ scheme
+ chicken
+ data-structures
+ posix
+ ports
+ extras
+
+ ;; scheme
+ ;; chicken.base
+ ;; chicken.string
+ ;; chicken.time
+ ;; chicken.time.posix
+ ;; chicken.port
+ ;; chicken.process-context
+ ;; chicken.process-context.posix
+
+ (prefix mtargs args:)
+ srfi-1
+ ;; system-information
+ )
+
+;;======================================================================
+;; debug stuff
+;;======================================================================
+
+(define verbosity (make-parameter '()))
+(define *default-log-port* (current-error-port))
+(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print
+
+(define (debug:setup)
+ (let ((debugstr (or (args:get-arg "-debug")
+ (args:get-arg "-debug-noprop")
+ (get-environment-variable "MT_DEBUG_MODE"))))
+ (verbosity (debug:calc-verbosity debugstr 'q))
+ (debug:check-verbosity (verbosity) debugstr)
+ ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+ (if (not (verbosity))(verbosity 1))
+ (if (and (not (args:get-arg "-debug-noprop"))
+ (or (args:get-arg "-debug")
+ (not (get-environment-variable "MT_DEBUG_MODE"))))
+ (setenv #;set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
+ (string-intersperse (map conc (verbosity)) ",")
+ (conc (verbosity)))))))
+
+;; check verbosity, #t is ok
+(define (debug:check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
+;;======================================================================
+;; (define (debug:print . params) #f)
+;; (define (debug:print-info . params) #f)
+;;
+;; (define (set-functions dbgp dbgpinfo)
+;; (set! debug:print dbgp)
+;; (set! debug:print-info dbgpinfo))
+
+;;======================================================================
+;; this was cached based on results from profiling but it turned out the profiling
+;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; in for now but can probably take it out later.
+;;
+(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
+ (let* ((res (cond
+ ((number? vstr) vstr)
+ ((not (string? vstr)) 1)
+ ;; ((string-match "^\\s*$" vstr) 1)
+ (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
+ (cond
+ ((> (length debugvals) 1) debugvals)
+ ((> (length debugvals) 0)(car debugvals))
+ (else 1))))
+ ((eq? arg 'v) 2) ;; verbose
+ ((eq? arg 'q) 0) ;; quiet
+ (else 1))))
+ (verbosity res)
+ res))
+
+;;======================================================================
+;; check verbosity, #t is ok
+#;(define (debug-check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
+(define (debug:debug-mode n)
+ (let* ((vb (verbosity)))
+ (cond
+ ((and (number? vb) ;; number number
+ (number? n))
+ (<= n vb))
+ ((and (list? vb) ;; list number
+ (number? n))
+ (member n vb))
+ ((and (list? vb) ;; list list
+ (list? n))
+ (not (null? (lset-intersection! eq? vb n))))
+ ((and (number? vb)
+ (list? n))
+ (member vb n))
+ (else #f))))
+
+(define (debug:handle-remote-logging params)
+ (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now
+ ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") "
+ (string-intersperse (map conc params) " ") "; "
+ (string-intersperse (command-line-arguments) " ")))))
+
+(define debug:enable-timestamp (make-parameter #t))
+
+(define (debug:timestamp)
+ (if (debug:enable-timestamp)
+ (conc (time->string
+ (seconds->local-time (current-seconds)) "%H:%M:%S") " ")
+ ""))
+
+ (define (debug:print n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (or e (current-error-port))
+ (lambda ()
+ ;; (if *logging*
+ ;; (db:log-event (apply conc params))
+ (apply print (debug:timestamp) params)
+ ;; (debug:handle-remote-logging params)
+ )))
+ #t ;; only here to make remote stuff happy. It'd be nice to fix that ...
+ )
+
+(define (debug:print-error n e . params)
+ ;; normal print
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "ERROR: " (debug:timestamp) params)
+ ;; (debug:handle-remote-logging (cons "ERROR: " params))
+ )))
+ ;; pass important messages to stderr
+ (if (and (eq? n 0)(not (eq? e (current-error-port))))
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print "ERROR: " (debug:timestamp) params)
+ ))))
+
+(define (debug:print-info n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res)
+ ;; (debug:handle-remote-logging (cons "INFO: " params))
+ ))))
+
+(define (debug:print-warn n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res)
+ ;; (debug:handle-remote-logging (cons "WARN: " params))
+ ))))
+)
DELETED filedb.scm
Index: filedb.scm
==================================================================
--- filedb.scm
+++ /dev/null
@@ -1,255 +0,0 @@
-;; Copyright 2006-2011, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-;;
-
-;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
-(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit filedb))
-
-(include "fdb_records.scm")
-;; (include "settings.scm")
-
-(define (filedb:open-db dbpath)
- (let* ((fdb (make-filedb:fdb))
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath)))
- (filedb:fdb-set-db! fdb db)
- (filedb:fdb-set-dbpath! fdb dbpath)
- (filedb:fdb-set-pathcache! fdb (make-hash-table))
- (filedb:fdb-set-idcache! fdb (make-hash-table))
- (filedb:fdb-set-partcache! fdb (make-hash-table))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
- (if (not dbexists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
- (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
- ;; NB// We store a useful subset of file attributes but do not attempt to store all
- (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
- path TEXT,
- parent_id INTEGER,
- mode INTEGER DEFAULT -1,
- uid INTEGER DEFAULT -1,
- gid INTEGER DEFAULT -1,
- size INTEGER DEFAULT -1,
- mtime INTEGER DEFAULT -1);")
- (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
- (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
- ;; close the sqlite3 db and open it as needed
- (filedb:finalize-db! fdb)
- (filedb:fdb-set-db! fdb #f)
- fdb))
-
-(define (filedb:reopen-db fdb)
- (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
- (filedb:fdb-set-db! fdb db)
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
-
-(define (filedb:finalize-db! fdb)
- (sqlite3:finalize! (filedb:fdb-get-db fdb)))
-
-(define (filedb:get-current-time-string)
- (string-chomp (time->string (seconds->local-time (current-seconds)))))
-
-(define (filedb:get-base-id db path)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:get-path-id db path parent)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path parent)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:add-base db path)
- (let ((existing (filedb:get-base-id db path)))
- (if existing #f
- (begin
- (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
-
-;; index value field notes
-;; 0 inode number st_ino
-;; 1 mode st_mode bitfield combining file permissions and file type
-;; 2 number of hard links st_nlink
-;; 3 UID of owner st_uid as with file-owner
-;; 4 GID of owner st_gid
-;; 5 size st_size as with file-size
-;; 6 access time st_atime as with file-access-time
-;; 7 change time st_ctime as with file-change-time
-;; 8 modification time st_mtime as with file-modification-time
-;; 9 parent device ID st_dev ID of device on which this file resides
-;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
-;; 11 block size st_blksize
-;; 12 number of blocks allocated st_blocks
-
-(define (filedb:add-path-stat db path parent statinfo)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
- (sqlite3:execute stmt
- path
- parent
- (vector-ref statinfo 1) ;; mode
- (vector-ref statinfo 3) ;; uid
- (vector-ref statinfo 4) ;; gid
- (vector-ref statinfo 5) ;; size
- (vector-ref statinfo 8) ;; mtime
- )
- (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
-
-(define (filedb:add-path db path parent)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
- (sqlite3:execute stmt path parent)
- (sqlite3:finalize! stmt)))
-
-(define (filedb:register-path fdb path #!key (save-stat #f))
- (let* ((db (filedb:fdb-get-db fdb))
- (pathcache (filedb:fdb-get-pathcache fdb))
- (stat (if save-stat (file-stat path #t)))
- (id (hash-table-ref/default pathcache path #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if id id
- (let ((plist (string-split path "/")))
- (let loop ((head (car plist))
- (tail (cdr plist))
- (parent 0))
- (let ((id (filedb:get-path-id db head parent))
- (done (null? tail)))
- (if id ;; we'll have a id if the path is already registered
- (if done
- (begin
- (hash-table-set! pathcache path id)
- id) ;; return the last path id for a result
- (loop (car tail)(cdr tail) id))
- (begin ;; add the path and then repeat the loop with the same data
- (if save-stat
- (filedb:add-path-stat db head parent stat)
- (filedb:add-path db head parent))
- (loop head tail parent)))))))))
-
-(define (filedb:update-recursively fdb path #!key (save-stat #f))
- (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
- (print "processed 0 files...")
- (let loop ((l (read-line p))
- (lc 0)) ;; line count
- (if (eof-object? l)
- (begin
- (print " " lc " files")
- (close-input-port p))
- (begin
- (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
- (if (= (modulo lc 100) 0)
- (print " " lc " files"))
- (loop (read-line p)(+ lc 1)))))))
-
-(define (filedb:update fdb path #!key (save-stat #f))
- ;; first get the realpath and add it to the bases table
- (let ((real-path path) ;; (filedb:get-real-path path))
- (db (filedb:fdb-get-db fdb)))
- (filedb:add-base db real-path)
- (filedb:update-recursively fdb path save-stat: save-stat)))
-
-;; not used and broken
-;;
-(define (filedb:get-real-path path)
- (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
- (pth (read-line p)))
- (if (eof-object? pth) path
- (begin
- (close-input-port p)
- pth))))
-
-(define (filedb:drop-base fdb path)
- (print "Sorry, I don't do anything yet"))
-
-(define (filedb:find-all fdb pattern action)
- (let* ((db (filedb:fdb-get-db fdb))
- (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
- (result '()))
- (sqlite3:for-each-row
- (lambda (num)
- (action num)
- (set! result (cons num result))) stmt pattern)
- (sqlite3:finalize! stmt)
- result))
-
-(define (filedb:get-path-record fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (partcache (filedb:fdb-get-partcache fdb))
- (dat (hash-table-ref/default partcache id #f)))
- (if dat dat
- (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
- (result #f))
- (sqlite3:for-each-row
- (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
- (hash-table-set! partcache id result)
- (sqlite3:finalize! stmt)
- result))))
-
-(define (filedb:get-children fdb parent-id)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
- parent-id)
- res))
-
-;; retrieve all that have children and those without
-;; children that match patt
-(define (filedb:get-children-patt fdb parent-id search-patt)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- ;; first get the children that have no children
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
- (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
- parent-id search-patt)
- res))
-
-(define (filedb:get-path fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (idcache (filedb:fdb-get-idcache fdb))
- (path (hash-table-ref/default idcache id #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if path path
- (let loop ((curr-id id)
- (path ""))
- (let ((path-record (filedb:get-path-record fdb curr-id)))
- (if (not path-record) #f ;; this id has no path
- (let* ((parent-id (list-ref path-record 1))
- (pname (list-ref path-record 0))
- (newpath (string-append "/" pname path)))
- (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
- (begin
- (hash-table-set! idcache id newpath)
- newpath)
- (loop parent-id newpath)))))))))
-
-(define (filedb:search db pattern)
- (let ((action (lambda (id)(print (filedb:get-path db id)))))
- (filedb:find-all db pattern action)))
-
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S T R A N S P O R T S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
- (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
- (set! *dbstruct-db* (db:setup-db)))
- (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *dbstruct-db* packet))
-
DELETED ftail.scm
Index: ftail.scm
==================================================================
--- ftail.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-;;======================================================================
-;; Copyright 2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;;======================================================================
-
-(declare (unit ftail))
-
-(module ftail
- (
- open-tail-db
- tail-write
- tail-get-fid
- file-tail
- )
-
-(import scheme chicken data-structures extras)
-(use (prefix sqlite3 sqlite3:) posix typed-records)
-
-(define (open-tail-db )
- (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
- (dbpath (conc basedir "/megatest_logs.db"))
- (dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ))
- db))
-
-(define (tail-write db fid lines)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (line)
- (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
- lines))))
-
-(define (tail-get-fid db fname)
- (let ((fid (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
- (if fid
- fid
- (begin
- (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
- (tail-get-fid db fname)))))
-
-(define (file-tail fname #!key (db-in #f))
- (let* ((inp (open-input-file fname))
- (db (or db-in (open-tail-db)))
- (fid (tail-get-fid db fname)))
- (let loop ((inl (read-line inp))
- (lines '())
- (lastwr (current-seconds)))
- (if (eof-object? inl)
- (let ((timed-out (> (- (current-seconds) lastwr) 60)))
- (if timed-out (tail-write db fid (reverse lines)))
- (sleep 1)
- (if timed-out
- (loop (read-line inp) '() (current-seconds))
- (loop (read-line inp) lines lastwr)))
- (let* ((savelines (> (length lines) 19)))
- ;; (print inl)
- (if savelines (tail-write db fid (reverse lines)))
- (loop (read-line inp)
- (if savelines
- '()
- (cons inl lines))
- (if savelines
- (current-seconds)
- lastwr)))))))
-
-;; offset -20 means get last 20 lines
-;;
-(define (tail-get-lines db fid offset count)
- (if (> offset 0)
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
- (reverse ;; get N from the end
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
-
-)
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -35,14 +35,18 @@
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))
;; (declare (uses daemon))
(declare (uses portlogger))
(declare (uses rmt))
+(declare (uses dbfile))
+(declare (uses commonmod))
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
+
+(import dbfile commonmod)
(require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
@@ -97,11 +101,11 @@
(dat ($ 'dat))
(res #f))
(cond
((equal? (uri-path (request-uri (current-request)))
'(/ "api"))
- (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
+ (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc
headers: '((content-type text/plain)))
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
((equal? (uri-path (request-uri (current-request)))
@@ -171,13 +175,13 @@
(debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
;; (start-server bind-address: ipaddrstr port: portnum)
(if config-hostname ;; this is a hint to bind directly
- (start-server port: portnum bind-address: (if (equal? config-hostname "-")
- ipaddrstr
- config-hostname))
+ (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-")
+ ;; ipaddrstr
+ ;; config-hostname))
(start-server port: portnum))
(portlogger:open-run-close portlogger:set-port portnum "released")
(debug:print 1 *default-log-port* "INFO: server has been stopped"))))
;;======================================================================
@@ -281,29 +285,32 @@
(begin
(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
(debug:print 0 *default-log-port* " message: " msg ", exn=" exn)
(debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey"))
(debug:print 0 *default-log-port* " call-chain: " call-chain)))
- (if runremote
- (remote-conndat-set! runremote #f))
+ (set! *runremote* #f)
+ (set! runremote #f)
+ ;; (if runremote
+ ;; (remote-conndat-set! runremote #f))
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
- ;;; (signal (make-composite-condition
- ;;; (make-property-condition 'commfail 'message "failed to connect to server")))
- ;;; "communications failed"
+ ;; (signal (make-composite-condition
+ ;; (make-property-condition 'commfail 'message "failed to connect to server")))
+ ;; "communications failed"
+ (close-all-connections!)
(db:obj->string #f))
- (with-input-from-request ;; was dat
- fullurl
- (list (cons 'key (or server-id "thekey"))
- (cons 'cmd cmd)
- (cons 'params sparams))
- read-string))
+ (with-input-from-request ;; was dat
+ fullurl
+ (list (cons 'key (or server-id "thekey"))
+ (cons 'cmd cmd)
+ (cons 'params sparams))
+ read-string))
transport: 'http)
- 0)) ;; added this speculatively
+ 0)) ;; added this speculatively
;; Shouldn't this be a call to the managed call-all-connections stuff above?
- (close-all-connections!)
+ ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections?
(mutex-unlock! *http-mutex*)
))
(time-out (lambda ()
(thread-sleep! 45)
(debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
@@ -350,11 +357,11 @@
exn
(begin
(print-call-chain *default-log-port*)
(debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
(close-connection! api-dat)
- ;;(close-idle-connections!)
+ (close-idle-connections!)
#t))
#f)))
(define (make-http-transport:server-dat)(make-vector 6))
@@ -390,10 +397,13 @@
(let* ((api-url (conc "http://" iface ":" port "/api"))
(api-uri (uri-reference (conc "http://" iface ":" port "/api")))
(api-req (make-request method: 'POST uri: api-uri))
(server-dat (vector iface port api-uri api-url api-req (current-seconds) server-id)))
server-dat))
+
+
+
;; run http-transport:keep-running in a parallel thread to monitor that the db is being
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running)
@@ -400,10 +410,11 @@
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; This thread waits for the server to come alive
(debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
(let* ((sdat #f)
+ (no-sync-db (db:open-no-sync-db))
(tmp-area (common:get-db-tmp-area))
(started-file (conc tmp-area "/.server-started"))
(server-start-time (current-seconds))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
@@ -457,18 +468,36 @@
(let loop ((count 0)
(server-state 'available)
(bad-sync-count 0)
(start-time (current-milliseconds)))
+
;; Use this opportunity to sync the tmp db to megatest.db
- (if (not server-going) ;; *dbstruct-db*
+ (if (not server-going) ;; *dbstruct-dbs*
(begin
(debug:print 0 *default-log-port* "SERVER: dbprep")
- (set! *dbstruct-db* (db:setup #t)) ;; run-id))
+ (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!!
(set! server-going #t)
(debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
- (thread-start! *watchdog*)))
+
+ ;; (thread-start! *watchdog*)
+ )
+ (if (and no-sync-db
+ (common:low-noise-print 5 "sync-all")) ;; cheesy way to reduce frequency of running sync :)
+ (begin
+ (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S"))
+
+ ;; This is tougher than it seems - have to deal with multiple dbs
+ ;; (db:process-transaction-queue *dbstruct-dbs*)
+
+ (db:all-db-sync *dbstruct-dbs*)
+
+ ;; (db:do-sync no-sync-db)
+ ;; (db:run-lock-and-sync *no-sync-db*)
+ )
+ )
+ )
;; when things go wrong we don't want to be doing the various queries too often
;; so we strive to run this stuff only every four seconds or so.
(let* ((sync-time (- (current-milliseconds) start-time))
(rem-time (quotient (- 4000 sync-time) 1000)))
@@ -490,11 +519,10 @@
(debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
(set! iface new-iface)
(set! port new-port)
(if (not *server-id*)
(set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
(debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
(flush-output *default-log-port*)))
;; Transfer *db-last-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
@@ -502,31 +530,47 @@
(mutex-unlock! *heartbeat-mutex*)
(if (common:low-noise-print 120 (conc "server running on " iface ":" port))
(begin
(if (not *server-id*)
- (set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
- (flush-output *default-log-port*)))
+ (set! *server-id* (server:mk-signature)))
+ (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
+ (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
+ (flush-output *default-log-port*)))
(if (common:low-noise-print 60 "dbstats")
(begin
(debug:print 0 *default-log-port* "Server stats:")
(db:print-current-query-stats)))
(let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
(cond
+ #;((and *server-run*
+ (> (- (current-seconds) server-start-time) 420)) ;; let's try server replacement
+ ;; ((adj-proc-load . 0.056875) (adj-core-load . 0.11375) (1m-load . 0.91) (5m-load . 0.77) (15m-load . 1.0) (proc . 16) (core . 8) (phys . 1))
+ (let* ((loaddat (common:get-normalized-cpu-load #f))
+ (adj-proc-load (alist-ref 'adj-proc-load loaddat))
+ (adj-core-load (alist-ref 'adj-core-load loaddat))
+ (adj-load (max adj-proc-load adj-core-load)))
+ (if (< adj-load 2) ;; reduce chance of runaway
+ (server:run *toppath*))
+ (db:all-db-sync *dbstruct-dbs*)
+ (thread-sleep! 30)
+ (http-transport:server-shutdown port)))
((and *server-run*
(> (+ last-access server-timeout)
(current-seconds)))
(if (common:low-noise-print 120 "server continuing")
(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(let ((curr-time (current-seconds)))
(handle-exceptions
exn
(debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn)
- (if (not *server-overloaded*)
- (change-file-times server-log-file curr-time curr-time)))))
+ (if (and (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter
+ (not *server-overloaded*))
+ (change-file-times server-log-file curr-time curr-time)
+ (if (common:low-noise-print 120 "start new server")
+ (server:kind-run *toppath*) ;; server:kind-run uses [servers] numservers
+ )))))
(loop 0 server-state bad-sync-count (current-milliseconds)))
(else
(debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
(http-transport:server-shutdown port)))))))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -481,11 +481,11 @@
;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
- (rmt:general-call 'set-test-start-time #f test-id)
+ (rmt:general-call 'set-test-start-time run-id test-id)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
@@ -494,11 +494,11 @@
(debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(debug:print 0 *default-log-port* "exiting with status 1")
(exit 1))
((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
- (rmt:general-call 'set-test-start-time #f test-id)
+ (rmt:general-call 'set-test-start-time run-id test-id)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f))
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
(debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(debug:print 0 *default-log-port* "exiting with status 1")
(exit 1))))
@@ -593,11 +593,11 @@
(list "MT_TARGET" target)
(list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(list "MT_TESTSUITENAME" (common:get-testsuite-name))))
;;(bb-check-path msg: "launch:execute post block 3")
- (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
+ (if mt-bindir-path (setenv "PATH" (conc "\""(getenv "PATH")":"mt-bindir-path"\"")))
;;(bb-check-path msg: "launch:execute post block 4")
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
@@ -1450,12 +1450,12 @@
(contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour")))
(let loop ((delta (- (current-seconds) *last-launch*))
(launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0)))
(if (> launch-delay delta)
(begin
- (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay.
- (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds"))
+ ;; (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay.
+ ;; (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds"))
(thread-sleep! (- launch-delay delta))
(loop (- (current-seconds) *last-launch*) launch-delay))))
(change-directory *toppath*)
(alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars)
(append
Index: margs.scm
==================================================================
--- margs.scm
+++ margs.scm
@@ -33,10 +33,15 @@
(define (args:get-arg-from ht arg . default)
(if (null? default)
(hash-table-ref/default ht arg #f)
(hash-table-ref/default ht arg (car default))))
+
+(define (args:remove-arg-from-ht arg)
+ (hash-table-delete! args:arg-hash arg)
+)
+
(define (args:usage . args)
(if (> (length args) 0)
(apply print "ERROR: " args))
(if (string? help)
(print help)
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -18,6 +18,6 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
;; (declare (unit megatest-version))
-(define megatest-version 1.6592)
+(define megatest-version 1.7006)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -30,21 +30,38 @@
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
+
(declare (uses db))
;; (declare (uses dcommon))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
+(declare (uses db))
+(declare (uses dbmod))
+(declare (uses dbmod.import))
+(declare (uses commonmod))
+(declare (uses commonmod.import))
+(declare (uses dbfile))
+(declare (uses dbfile.import))
+;; (declare (uses debugprint))
+;; (declare (uses debugprint.import))
+;; (declare (uses mtargs))
+;; (declare (uses mtargs.import))
+
;; (declare (uses ftail))
;; (import ftail)
+
+(import dbmod
+ commonmod
+ dbfile)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -62,10 +79,12 @@
(require-library mutils)
(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
+
+(dbfile:db-init-proc db:initialize-main-db)
;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
(if (common:file-exists? debugcontrolf)
@@ -494,19 +513,19 @@
;; The watchdog is to keep an eye on things like db sync etc.
;;
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define *watchdog* (make-thread
- (lambda ()
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (common:watchdog)))
- "Watchdog thread"))
+;;(define *watchdog* (make-thread
+;; (lambda ()
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (print-call-chain)
+;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
+;; (common:watchdog)))
+;; "Watchdog thread"))
;;(if (not (args:get-arg "-server"))
;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
(let* ((no-watchdog-args
'("-list-runs"
@@ -534,12 +553,14 @@
(loop (car tail) (cdr tail))))))
(no-watchdog-args-vals (filter (lambda (x) x)
(map args:get-arg no-watchdog-args)))
(start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog)
- (if start-watchdog
- (thread-start! *watchdog*)))
+;; (if start-watchdog
+;; (thread-start! *watchdog*))
+ #t
+)
;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
(condition-case
@@ -931,13 +952,13 @@
(if (or (args:get-arg "-list-servers")
(args:get-arg "-kill-servers"))
(let ((tl (launch:setup)))
(if tl ;; all roads from here exit
(let* ((servers (server:get-list *toppath*))
- (fmtstr "~8a~22a~20a~20a~8a\n"))
- (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State")
- (format #t fmtstr "===" "==============" "=========" "========" "=====")
+ (fmtstr "~33a~22a~20a~20a~8a\n"))
+ (format #t fmtstr "ID" "host:port" "age (hms)" "Last mod" "State")
+ (format #t fmtstr "==" "=========" "=========" "========" "=====")
(for-each ;; ( mod-time host port start-time pid )
(lambda (server)
(let* ((mtm (any->number (car server)))
(mod (if mtm (- (current-seconds) mtm) "unk"))
(age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
@@ -2290,22 +2311,22 @@
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
;; keep this one local
;; (open-run-close patch-db #f)
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct full: #t))
+ (let ((dbstructs (db:setup #f)))
+ (common:cleanup-db dbstructs full: #t))
(set! *didsomething* #t)))
(if (args:get-arg "-cleanup-db")
(begin
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct))
+ (let ((dbstructs (db:setup #f)))
+ (common:cleanup-db dbstructs))
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
(if (not (launch:setup))
@@ -2357,14 +2378,14 @@
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
- (dbstruct (if (and toppath
- (common:on-homehost?))
- (db:setup #t)
- #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
+ (dbstructs (if (and toppath
+ (common:on-homehost?))
+ (db:setup #t)
+ #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
((getenv "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
@@ -2377,15 +2398,16 @@
;; EOF
(repl))
(else
(begin
- (set! *db* dbstruct)
+ (set! *db* dbstructs)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
+ (import dbfile)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(if *use-new-readline*
(begin
(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
@@ -2447,27 +2469,29 @@
;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me (set! *didsomething* #t)))
(if (args:get-arg "-import-megatest.db")
(begin
+ (launch:setup)
(db:multi-db-sync
(db:setup #f)
'killservers
'dejunk
'adj-testids
'old2new
- ;; 'new2old
)
(set! *didsomething* #t)))
(when (args:get-arg "-sync-brute-force")
+ (launch:setup)
((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
(set! *didsomething* #t))
(if (args:get-arg "-sync-to-megatest.db")
- (let* ((dbstruct (db:setup #f))
- (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
+ (let* ((duh (launch:setup))
+ (dbstruct (db:setup #t))
+ (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
(res (if locked
(db:multi-db-sync
dbstruct
@@ -2533,14 +2557,14 @@
;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(if (thread? *watchdog*)
- (case (thread-state *watchdog*)
- ((ready running blocked sleeping terminated dead)
- (thread-join! *watchdog*))))
+;;(if (thread? *watchdog*)
+;; (case (thread-state *watchdog*)
+;; ((ready running blocked sleeping terminated dead)
+;; (thread-join! *watchdog*))))
(set! *time-to-exit* #t)
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
Index: mtargs/mtargs.scm
==================================================================
--- mtargs/mtargs.scm
+++ mtargs/mtargs.scm
@@ -56,10 +56,20 @@
(if (string? help)
(print help)
(print "Usage: " (car (argv)) " ... "))
(exit 0))
+ ;; one-of args defined
+(define (args:any-defined? . param)
+ (let ((res #f))
+ (for-each
+ (lambda (arg)
+ (if (get-arg arg)(set! res #t)))
+ param)
+ res))
+
+;; args:
(define (get-args args params switches arg-hash num-needed)
(let* ((numtargs (length args))
(adj-num-needed (if num-needed (+ num-needed 2) #f)))
(if (< numtargs (if adj-num-needed adj-num-needed 2))
(if (>= num-needed 1)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -21,14 +21,15 @@
(use format typed-records) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
+(declare (uses dbfile))
(include "common_records.scm")
;; (declare (uses rmtmod))
-;; (import rmtmod)
+(import dbfile) ;; rmtmod)
;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;
@@ -63,11 +64,11 @@
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
#;(common:telemetry-log (conc "rmt:"(->string cmd))
payload: `((rid . ,rid)
(params . ,params)))
-
+
(if (> attemptnum 2)
(debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
(cond
((> attemptnum 2) (thread-sleep! 0.05))
@@ -119,10 +120,17 @@
(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
(remote-hh-dat-set! runremote (common:get-homehost)))
;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
(cond
+ #;((> (- (current-seconds)(remote-connect-time runremote)) 180) ;; reconnect to server every 180 seconds
+ (debug:print 0 *default-log-port* "Forcing reconnect to server(s) due to 180 second timeout.")
+ (set! *runremote* #f)
+ ;; BUG: close-connections should go here?
+ (mutex-unlock! *rmt-mutex*)
+ (rmt:send-receive cmd rid params attemptnum: 1 area-dat: area-dat))
+
;;DOT EXIT;
;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
;; give up if more than 150 attempts
((> attemptnum 150)
(debug:print 0 *default-log-port* "ERROR: 150 tries to start/connect to server. Giving up.")
@@ -368,28 +376,28 @@
(loop (car tal)(cdr tal) newmax-cmd currmax)))))))
(mutex-unlock! *db-stats-mutex*)
res))
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
- (let* ((qry-is-write (not (member cmd api:read-only-queries)))
- (db-file-path (db:dbfile-path)) ;; 0))
- (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
- (read-only (not (file-write-access? db-file-path)))
- (start (current-milliseconds))
- (resdat (if (not (and read-only qry-is-write))
- (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
- (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
- exn ;; This is an attempt to detect that situation and recover gracefully
- (begin
- (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
- (if (and (vector? v)
- (> (vector-length v) 1))
- (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
- newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
- (vector #t '())))) ;; we could also check that the returned types are valid
- (vector #t '())))
+ (let* ((qry-is-write (not (member cmd api:read-only-queries)))
+ (db-file-path (db:dbfile-path)) ;; 0))
+ (dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
+ (read-only (not (file-write-access? db-file-path)))
+ (start (current-milliseconds))
+ (resdat (if (not (and read-only qry-is-write))
+ (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
+ ;; (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
+ ;; exn ;; This is an attempt to detect that situation and recover gracefully
+ ;; (begin
+ ;; (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ ;; (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
+ (if (and (vector? v)
+ (> (vector-length v) 1))
+ (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
+ newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
+ (vector #t '()))) ;; ) ;; we could also check that the returned types are valid
+ (vector #t '())))
(success (vector-ref resdat 0))
(res (vector-ref resdat 1))
(duration (- (current-milliseconds) start)))
(if (and read-only qry-is-write)
(debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
@@ -412,16 +420,16 @@
(mutex-unlock! *db-multi-sync-mutex*)))))
res))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(let* ((run-id (if run-id run-id 0))
- (res (handle-exceptions
- exn
- (begin
- (print "transport failed. exn=" exn)
- #f)
- (http-transport:client-api-send-receive run-id connection-info cmd params))))
+ (res ;; (handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (print "transport failed. exn=" exn)
+ ;; #f)
+ (http-transport:client-api-send-receive run-id connection-info cmd params))) ;; )
(if (and res (vector-ref res 0))
(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
#f)))
;;======================================================================
@@ -525,10 +533,11 @@
(define (rmt:get-targets)
(rmt:send-receive 'get-targets #f '()))
(define (rmt:get-target run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-target run-id (list run-id)))
(define (rmt:get-run-times runpatt targetpatt)
(rmt:send-receive 'get-run-times #f (list runpatt targetpatt )))
@@ -537,13 +546,15 @@
;; T E S T S
;;======================================================================
;; Just some syntatic sugar
(define (rmt:register-test run-id test-name item-path)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:general-call 'register-test run-id run-id test-name item-path))
(define (rmt:get-test-id run-id testname item-path)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
;; run-id is NOT used
;;
(define (rmt:get-test-info-by-id run-id test-id)
@@ -556,39 +567,46 @@
(define (rmt:test-get-rundir-from-test-id run-id test-id)
(rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
+ (assert (number? run-id) "FATAL: Run id required.")
(let* ((test-path (if (string? work-area)
work-area
(rmt:test-get-rundir-from-test-id run-id test-id))))
(debug:print 3 *default-log-port* "TEST PATH: " test-path)
(open-test-db test-path)))
;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
-(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
+(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
+ (assert (number? run-id) "FATAL: Run id required.")
;; (if (number? run-id)
(rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
;; (begin
;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
;; (print-call-chain (current-error-port))
;; '())))
(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
;; get stuff via synchash
(define (rmt:synchash-get run-id proc synckey keynum params)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
;; IDEA: Threadify these - they spend a lot of time waiting ...
;;
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
@@ -631,40 +649,50 @@
;; (apply append (map (lambda (run-id)
;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
;; run-id-list))))
(define (rmt:delete-test-records run-id test-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
(define (rmt:test-set-state-status run-id test-id state status msg)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg)))
(define (rmt:test-toplevel-num-items run-id test-name)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))
;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
(define (rmt:test-get-logfile-info run-id test-name)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
(define (rmt:test-get-records-for-index-file run-id test-name)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
(define (rmt:get-testinfo-state-status run-id test-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
(define (rmt:test-set-log! run-id test-id logf)
+ (assert (number? run-id) "FATAL: Run id required.")
(if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
(define (rmt:test-set-top-process-pid run-id test-id pid)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
(define (rmt:test-get-top-process-pid run-id test-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
(rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
@@ -676,57 +704,71 @@
(map (lambda (run-id)
(rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
run-ids))))
(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
(define (rmt:get-count-tests-running-for-run-id run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
(define (rmt:get-not-completed-cnt run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
;; Statistical queries
(define (rmt:get-count-tests-running run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-count-tests-running run-id (list run-id)))
(define (rmt:get-count-tests-running-for-testname run-id testname)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
;; state and status are extra hints not usually used in the calculation
;;
(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
(define (rmt:set-state-status-and-roll-up-run run-id state status)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))
(define (rmt:update-pass-fail-counts run-id test-name)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name))
(define (rmt:top-test-set-per-pf-counts run-id test-name)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
(define (rmt:get-raw-run-stats run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
(define (rmt:get-test-times runname target)
(rmt:send-receive 'get-test-times #f (list runname target )))
;;======================================================================
;; R U N S
;;======================================================================
+;; BUG - LOOK AT HOW THIS WORKS!!!
+;;
(define (rmt:get-run-info run-id)
- (rmt:send-receive 'get-run-info run-id (list run-id)))
+ (assert (number? run-id) "FATAL: Run id required.")
+ (rmt:send-receive 'get-run-info #f (list run-id)))
(define (rmt:get-num-runs runpatt)
(rmt:send-receive 'get-num-runs #f (list runpatt)))
(define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
@@ -735,14 +777,15 @@
;; Use the special run-id == #f scenario here since there is no run yet
(define (rmt:register-run keyvals runname state status user contour)
(rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
(define (rmt:get-run-name-from-id run-id)
- (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
+ (assert (number? run-id) "FATAL: Run id required.")
+ (rmt:send-receive 'get-run-name-from-id #f (list run-id)))
(define (rmt:delete-run run-id)
- (rmt:send-receive 'delete-run run-id (list run-id)))
+ (rmt:send-receive 'delete-run #f (list run-id)))
(define (rmt:update-run-stats run-id stats)
(rmt:send-receive 'update-run-stats #f (list run-id stats)))
(define (rmt:delete-old-deleted-test-records)
@@ -756,43 +799,52 @@
(define (rmt:get-all-run-ids)
(rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:get-prev-run-ids run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-prev-run-ids #f (list run-id)))
(define (rmt:lock/unlock-run run-id lock unlock user)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
;; set/get status
(define (rmt:get-run-status run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-run-status #f (list run-id)))
(define (rmt:get-run-state run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-run-state #f (list run-id)))
(define (rmt:set-run-status run-id run-status #!key (msg #f))
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
(define (rmt:set-run-state-status run-id state status )
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'set-run-state-status #f (list run-id state status)))
(define (rmt:update-tesdata-on-repilcate-db old-lt new-lt)
(rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt)))
(define (rmt:update-run-event_time run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
(rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
+ (assert (number? run-id) "FATAL: Run id required.")
;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
(rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
(define (rmt:get-main-run-stats run-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-main-run-stats #f (list run-id)))
(define (rmt:get-var varname)
(rmt:send-receive 'get-var #f (list varname)))
@@ -869,39 +921,46 @@
;;
;;(define (rmt:get-steps-for-test run-id test-id)
;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
+ (assert (number? run-id) "FATAL: Run id required.")
(let* ((state (items:check-valid-items "state" state-in))
(status (items:check-valid-items "status" status-in)))
(if (or (not state)(not status))
(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
(define (rmt:delete-steps-for-test! run-id test-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id)))
(define (rmt:get-steps-for-test run-id test-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
-(define (rmt:get-steps-info-by-id test-step-id)
- (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id)))
+(define (rmt:get-steps-info-by-id run-id test-step-id)
+ (assert (number? run-id) "FATAL: Run id required.")
+ (rmt:send-receive 'get-steps-info-by-id #f (list run-id test-step-id)))
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f))
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
(define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f))
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt)))
-(define (rmt:get-data-info-by-id test-data-id)
- (rmt:send-receive 'get-data-info-by-id #f (list test-data-id)))
+(define (rmt:get-data-info-by-id run-id test-data-id)
+ (assert (number? run-id) "FATAL: Run id required.")
+ (rmt:send-receive 'get-data-info-by-id #f (list run-id test-data-id)))
(define (rmt:testmeta-add-record testname)
(rmt:send-receive 'testmeta-add-record #f (list testname)))
(define (rmt:testmeta-get-record testname)
@@ -909,13 +968,15 @@
(define (rmt:testmeta-update-field test-name fld val)
(rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
(define (rmt:test-data-rollup run-id test-id status)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
(define (rmt:csv->test-data run-id test-id csvdata)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
;;======================================================================
;; T A S K S
;;======================================================================
@@ -963,10 +1024,11 @@
(define (rmt:archive-register-disk bdisk-name bdisk-path df)
(rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
+ (assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
(define (rmt:test-get-archive-block-info archive-block-id)
(rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
@@ -973,12 +1035,12 @@
(define (rmtmod:calc-ro-mode runremote *toppath*)
(if (and runremote
(remote-ro-mode-checked runremote))
(remote-ro-mode runremote)
- (let* ((dbfile (conc *toppath* "/megatest.db"))
- (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
+ (let* ((mtcfgfile (conc *toppath* "/megatest.config"))
+ (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
(if runremote
(begin
(remote-ro-mode-set! runremote ro-mode)
(remote-ro-mode-checked-set! runremote #t)
ro-mode)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -312,10 +312,25 @@
(begin
(hash-table-set! *runs:denoise* key currtime)
#t)
#f)))
+(define *last-test-launch* 0)
+(define *too-soon-delays* (make-hash-table))
+
+;; to-soon delay, when matching event happened in less than dseconds delay wseconds
+;;
+(define (runs:too-soon-delay key dseconds wseconds)
+ (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f)))
+ (if (and last-time
+ (< (- (current-seconds) last-time) dseconds))
+ (begin
+ (if (runs:lownoise (conc "too-soon-delay"key) 60)
+ (debug:print-info 2 *default-log-port* "Polling throttle for "key))
+ (thread-sleep! wseconds)))
+ (hash-table-set! *too-soon-delays* key (current-seconds))))
+
(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
;; Take advantage of a good place to exit if running the one-pass methodology
(if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
(args:get-arg "-one-pass"))
@@ -508,12 +523,12 @@
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name)))
;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
- (dbfile (conc *toppath* "/megatest.db"))
- (readonly-mode (not (file-write-access? dbfile)))
+ (mtconfig (conc *toppath* "/megatest.config"))
+ (readonly-mode (not (file-write-access? mtconfig)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
(test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
@@ -526,11 +541,11 @@
(allowed-tests #f)
(runconf #f))
;; check if readonly
(when readonly-mode
- (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.")
+ (debug:print-error 0 *default-log-port* "Megatest database is readonly. Cannot proceed.")
(exit 1))
;; per user request. If less than 100Meg space on dbdir partition, bail out with error
;; this will reduce issues in database corruption
(common:check-db-dir-and-exit-if-insufficient)
@@ -1287,10 +1302,11 @@
;; we are going to reset all the counters for test retries by setting a new hash table
;; this means they will increment only when nothing can be run
(set! *max-tries-hash* (make-hash-table))
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry runsdat testdat)
+ (set! *last-test-launch* (current-seconds))
(runs:incremental-print-results run-id)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
(runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(if (or (not (null? tal))(not (null? reg)))
@@ -1502,10 +1518,12 @@
;;
(define *max-tries-hash* (make-hash-table))
(define (runs:pretty-long-list lst)
(if (> (length lst) 8)(append (take lst 3)(list "...")) lst))
+
+(define *last-loop-time-ms* 0)
;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================
;;
@@ -1640,12 +1658,29 @@
testmode: testmode
newtal: newtal
itemmaps: itemmaps
;; prereqs-not-met: prereqs-not-met
)))
+
+ ;; too-tight loop detection and delay, this might hide issues
+ ;; that occur in long run times. Consider commenting when debugging
+ ;;
+ (if (and (>= num-running max-concurrent-jobs)
+ (< (- (current-milliseconds) *last-loop-time-ms*) 500))
+ (begin
+ (if (runs:lownoise "too-tight-loop" 5)
+ (debug:print-info 2 *default-log-port* "Excessively fast loop, delaying 1/2 second"))
+ (thread-sleep! 0.5)))
+ (set! *last-loop-time-ms* (current-milliseconds))
+
(runs:dat-regfull-set! runsdat regfull)
-
+
+
+ (if (> (- (current-seconds) *last-test-launch*) 5) ;; be pretty aggressive for five seconds after
+ (runs:too-soon-delay (conc "loop delay " hed) 1 0.6) ;; starting a test then apply more delay
+ (runs:too-soon-delay (conc "loop delay " hed) 1 0.1))
+
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
@@ -1890,11 +1925,11 @@
(rmt:set-var (conc "lunch-complete-" run-id) "yes")
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
- (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
+ (thread-sleep! 0.1) ;; I think there is a race condition here. Let states/statuses settle
(let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id))
(prev-num-running 0))
;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
(if (and (or (args:get-arg "-run-wait")
@@ -2347,15 +2382,15 @@
(bup-mutex (make-mutex))
(keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
(test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop
(let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
- (dbfile (conc *toppath* "/megatest.db"))
+ (dbfile (conc *toppath* "/.megatest/main.db"))
(readonly-mode (not (file-write-access? dbfile))))
(when (and readonly-mode
(member action write-access-actions))
- (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
+ (debug:print-error 0 *default-log-port* dbfile " is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
(exit 1)))
(debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
(begin
DELETED sdb.scm
Index: sdb.scm
==================================================================
--- sdb.scm
+++ /dev/null
@@ -1,116 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;;======================================================================
-
-;;======================================================================
-;; Simple persistant strings lookup table. Keep out of the main db
-;; so writes/reads don't slow down central access.
-;;======================================================================
-
-(require-extension (srfi 18) extras)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
-
-(declare (unit sdb))
-
-;;
-(define (sdb:open fname)
- (let* ((dbpath (pathname-directory fname))
- (dbexists (let ((fe (common:file-exists? fname)))
- (if fe
- fe
- (begin
- (create-directory dbpath #t)
- #f))))
- (sdb (sqlite3:open-database fname))
- (handler (make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! sdb handler)
- (if (not dbexists)
- (sdb:initialize sdb))
- (sqlite3:execute sdb "PRAGMA synchronous = 1;")
- sdb))
-
-(define (sdb:initialize sdb)
- (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
- (id INTEGER PRIMARY KEY,
- str TEXT,
- CONSTRAINT str UNIQUE (str));")
- (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))
-
-;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))
-
-(define (sdb:register-string sdb str)
- (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
-
-(define (sdb:string->id sdb str-cache str)
- (let ((id (hash-table-ref/default str-cache str #f)))
- (if (not id)
- (sqlite3:for-each-row
- (lambda (sid)
- (set! id sid)
- (hash-table-set! str-cache str id))
- sdb
- "SELECT id FROM strs WHERE str=?;" str))
- id))
-
-(define (sdb:id->string sdb id-cache id)
- (let ((str (hash-table-ref/default id-cache id #f)))
- (if (not str)
- (sqlite3:for-each-row
- (lambda (istr)
- (set! str istr)
- (hash-table-set! id-cache id str))
- sdb
- "SELECT str FROM strs WHERE id=?;" id))
- str))
-
-;; Numbers get passed though in both directions
-;;
-(define (make-sdb:qry fname)
- (let ((sdb #f)
- (scache (make-hash-table))
- (icache (make-hash-table)))
- (lambda (cmd var)
- (case cmd
- ((setup) (set! sdb (if (not sdb)
- (sdb:open (if var var fname)))))
- ((setdb) (set! sdb var))
- ((getdb) sdb)
- ((finalize) (if sdb
- (begin
- (sqlite3:finalize! sdb)
- (set! sdb #f))))
- ((getid) (let ((id (if (or (number? var)
- (string->number var))
- var
- (sdb:string->id sdb scache var))))
- (if id
- id
- (begin
- (sdb:register-string sdb var)
- (sdb:string->id sdb scache var)))))
- ((getstr) (if (or (number? var)
- (string->number var))
- (sdb:id->string sdb icache var)
- var))
- ((passid) var)
- ((passstr) var)
- (else #f)))))
-
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -23,18 +23,22 @@
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(declare (unit server))
+(declare (uses commonmod))
+
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses synchash))
(declare (uses http-transport))
;;(declare (uses rpc-transport))
(declare (uses launch))
;; (declare (uses daemon))
+
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(define (server:make-server-url hostport)
@@ -229,11 +233,11 @@
(exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
(exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
(directory-exists? (conc areapath "/logs")))
'()))
- ;; Get the list of server logs. First remove logs for servers that have exited.
+ ;; Get the list of server logs.
(let* (
;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers.
;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'")))
(server-logs (glob (conc areapath "/logs/server-*-*.log")))
(num-serv-logs (length server-logs)))
@@ -246,11 +250,11 @@
(tal (cdr server-logs))
(res '()))
(let* ((mod-time (handle-exceptions
exn
(begin
- (debug:print 0 *default-log-port* "failed to get modification time on " hed ", exn=" exn)
+ (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn)
(current-seconds)) ;; 0
(file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
(down-time (- (current-seconds) mod-time))
(serv-dat (if (or (< num-serv-logs 10)
(< down-time 900)) ;; day-seconds))
@@ -565,17 +569,19 @@
(if (equal? *toppath* toppath)
#t
#f)))
;; timeout is hms string: 1h 5m 3s, default is 1 minute
+;; This is currently broken. Just use the number of hours with no unit.
+;; Default is 60 seconds.
;;
(define (server:expiration-timeout)
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
(common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
(* 3600 (string->number tmo))
- 60)))
+ 1200)))
(define (server:get-best-guess-address hostname)
(let ((res #f))
(for-each
(lambda (adr)
@@ -606,11 +612,14 @@
;; moving this here as it needs access to db and cannot be in common.
;;
(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
- (let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
+ (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
+ (lambda ()
+ (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
+ #;(let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
(sync-log (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
(tmp-area (common:get-db-tmp-area))
(tmp-db (conc tmp-area "/megatest.db"))
(staging-file (conc *toppath* "/.megatest.db"))
(mtdbfile (conc *toppath* "/megatest.db"))
@@ -703,155 +712,5 @@
finalres)
) ;; end lambda
))
do-a-sync))
-(define (server:writable-watchdog-bruteforce dbstruct)
- (thread-sleep! 1) ;; delay for startup
- (let* ((do-a-sync (server:get-bruteforce-syncer dbstruct))
- (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t)))
- (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync
- (args:get-arg "-server"))
-
- (let loop ()
- (do-a-sync)
- (if (not *time-to-exit*) (loop))) ;; keep going unless time to exit
-
- ;; time to exit, close the no-sync db here
- (final-sync)
-
- (if (common:low-noise-print 30)
- (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)
- )))))
-
-(define (server:writable-watchdog-deltasync dbstruct)
- (thread-sleep! 0.05) ;; delay for startup
- (let ((legacy-sync (common:run-sync?))
- (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
- (debug-mode (debug:debug-mode 1))
- (last-time (current-seconds))
- (no-sync-db (db:open-no-sync-db))
- (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
- (sync-duration 0) ;; run time of the sync in milliseconds
- )
- (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
- (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
- (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num)
- (if (and legacy-sync (not *time-to-exit*))
- (let* (;;(dbstruct (db:setup))
- (mtdb (dbr:dbstruct-mtdb dbstruct))
- (mtpath (db:dbdat-get-path mtdb))
- (tmp-area (common:get-db-tmp-area))
- (start-file (conc tmp-area "/.start-sync"))
- (end-file (conc tmp-area "/.end-sync")))
- (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
- (let loop ()
- ;; sync for filesystem local db writes
- ;;
- (mutex-lock! *db-multi-sync-mutex*)
- (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
- (sync-in-progress *db-sync-in-progress*)
- (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
- (should-sync (and (not *time-to-exit*)
- (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
- (start-time (current-seconds))
- (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
- (mt-mod-time (file-modification-time mtpath))
- (last-sync-start (if (common:file-exists? start-file)
- (file-modification-time start-file)
- 0))
- (last-sync-end (if (common:file-exists? end-file)
- (file-modification-time end-file)
- 10))
- (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
- (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
- (< mt-mod-time last-sync-start)))
- (sync-done (<= last-sync-start last-sync-end))
- (sync-stale (> start-time (+ last-sync-start sync-stale-seconds)))
- (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting
- (or need-sync should-sync)
- (or sync-done sync-stale)
- (not sync-in-progress)
- (not recently-synced))))
- (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress
- " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
- " sync-done=" sync-done " sync-period=" sync-period)
- (if (and (> sync-period 5)
- (common:low-noise-print 30 "sync-period"))
- (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
- ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
- ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
- (if will-sync (set! *db-sync-in-progress* #t))
- (mutex-unlock! *db-multi-sync-mutex*)
- (if will-sync
- (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
- (sync-start (current-milliseconds)))
- (with-output-to-file start-file (lambda ()(print (current-process-id))))
-
- ;; put lock here
-
- ;; (if (or (not max-sync-duration)
- ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
- (let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
- (set! sync-duration (- (current-milliseconds) sync-start))
- (if (> res 0) ;; some records were transferred, keep the db alive
- (begin
- (mutex-lock! *heartbeat-mutex*)
- (set! *db-last-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*)
- (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
- (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))))
-;; ;; TODO: factor this next routine out into a function
-;; (with-input-from-pipe ;; this should not block other threads but need to verify this
-;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*)
-;; (lambda ()
-;; (let loop ((inl (read-line))
-;; (res #f))
-;; (if (eof-object? inl)
-;; (begin
-;; (set! sync-duration (- (current-milliseconds) sync-start))
-;; (cond
-;; ((not res)
-;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\""))
-;; ((> res 0)
-;; (mutex-lock! *heartbeat-mutex*)
-;; (set! *db-last-access* (current-seconds))
-;; (mutex-unlock! *heartbeat-mutex*))))
-;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl)))
-;; (if matches
-;; (string->number (cadr matches))
-;; #f))))
-;; (loop (read-line)
-;; (or num-synced res))))))))))
- (if will-sync
- (begin
- (mutex-lock! *db-multi-sync-mutex*)
- (set! *db-sync-in-progress* #f)
- (set! *db-last-sync* start-time)
- (with-output-to-file end-file (lambda ()(print (current-process-id))))
-
- ;; release lock here
-
- (mutex-unlock! *db-multi-sync-mutex*)))
- (if (and debug-mode
- (> (- start-time last-time) 60))
- (begin
- (set! last-time start-time)
- (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
-
- ;; keep going unless time to exit
- ;;
- (if (not *time-to-exit*)
- (let delay-loop ((count 0))
- ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
-
- (if (and (not *time-to-exit*)
- (< count 6)) ;; was 11, changing to 4.
- (begin
- (thread-sleep! 1)
- (delay-loop (+ count 1))))
- (if (not *time-to-exit*) (loop))))
- ;; time to exit, close the no-sync db here
- (db:no-sync-close-db no-sync-db stmt-cache)
- (if (common:low-noise-print 30)
- (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num)))))))
-
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -396,19 +396,19 @@
(if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
(begin
(sauth:print-error "Destination does not have enough disk space.")
(exit 1)))
(if (is_directory src-path)
- (begin
- (let* ((parent-dir src-path)
- (start-dir target-path))
- (run (pipe
- (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
- (begin (change-directory start-dir)
- ;(print "123")
- (run-cmd "tar" (list "xf" "-")))))
- (print "Copied data to " start-dir)))
+ (begin
+ (let* ((parent-dir src-path)
+ (start-dir target-path))
+ (run (pipe
+ (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
+ (begin (change-directory start-dir)
+ ;(print "123")
+ (run-cmd "tar" (list "xf" "-")))))
+ (print "Copied data to " start-dir)))
(begin
(let*((parent-dir (pathname-directory src-path))
(start-dir target-path)
(filename (if (pathname-extension src-path)
(conc(pathname-file src-path) "." (pathname-extension src-path))
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -47,11 +47,11 @@
(define (subrun:launch-dashboard test-run-dir)
(if (subrun:subrun-test-initialized? test-run-dir)
(let* ((subarea (subrun:get-runarea test-run-dir)))
(if (and subarea (common:file-exists? subarea))
- (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))))
+ (system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))))
(define (subrun:subrun-removed? test-run-dir)
(if (subrun:subrun-test-initialized? test-run-dir)
(let ((flagfile (conc test-run-dir "/subrun.removed")))
(if (common:file-exists? flagfile)
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -20,15 +20,17 @@
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(import (prefix sqlite3 sqlite3:))
(declare (unit tasks))
+(declare (uses dbfile))
(declare (uses db))
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))
+(import dbfile)
;; (import pgdb) ;; pgdb is a module
(include "task_records.scm")
(include "db_records.scm")
@@ -327,11 +329,11 @@
;; register a task
(define (tasks:add dbstruct action owner target runname testpatt params)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);"
action
owner
target
@@ -362,11 +364,11 @@
(define (tasks:snag-a-task dbstruct)
(let ((res #f)
(keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id))))))
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dat db)
;; first randomly set a new to pid-hostname-hostname
(sqlite3:execute
db
"UPDATE tasks_queue SET keylock=? WHERE id IN
(SELECT id FROM tasks_queue
@@ -389,11 +391,11 @@
(define (tasks:reset-stuck-tasks dbstruct)
(let ((res '()))
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dat db)
(sqlite3:for-each-row
(lambda (id delta)
(set! res (cons id res)))
db
"SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;")
@@ -406,11 +408,11 @@
;;
(define (tasks:get-tasks dbstruct types states)
(let ((res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id . rem)
(set! res (cons (apply vector id rem) res)))
db
(conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time
@@ -423,11 +425,11 @@
(define (tasks:get-last dbstruct target runname)
(let ((res #f))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id . rem)
(set! res (apply vector id rem)))
db
(conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time
@@ -440,26 +442,26 @@
;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
-#;(define (tasks:process-queue dbstruct)
- (let* ((task (tasks:snag-a-task dbstruct))
- (action (if task (tasks:task-get-action task) #f)))
- (if action (print "tasks:process-queue task: " task))
- (if action
- (case (string->symbol action)
- ((run) (tasks:start-run dbstruct task))
- ((remove) (tasks:remove-runs dbstruct task))
- ((lock) (tasks:lock-runs dbstruct task))
- ;; ((monitor) (tasks:start-monitor db task))
- #;((rollup) (tasks:rollup-runs dbstruct task))
- ((updatemeta)(tasks:update-meta dbstruct task))
- #;((kill) (tasks:kill-monitors dbstruct task))))))
+;; (define (tasks:process-queue dbstruct)
+;; (let* ((task (tasks:snag-a-task dbstruct))
+;; (action (if task (tasks:task-get-action task) #f)))
+;; (if action (print "tasks:process-queue task: " task))
+;; (if action
+;; (case (string->symbol action)
+;; ((run) (tasks:start-run dbstruct task))
+;; ((remove) (tasks:remove-runs dbstruct task))
+;; ((lock) (tasks:lock-runs dbstruct task))
+;; ;; ((monitor) (tasks:start-monitor db task))
+;; #;((rollup) (tasks:rollup-runs dbstruct task))
+;; ((updatemeta)(tasks:update-meta dbstruct task))
+;; #;((kill) (tasks:kill-monitors dbstruct task))))))
(define (tasks:tasks->text tasks)
(let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
(conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
(string-intersperse
@@ -477,11 +479,11 @@
tasks) "\n"))))
(define (tasks:set-state dbstruct task-id state)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;"
state
task-id))))
;;======================================================================
@@ -489,49 +491,48 @@
;;======================================================================
(define (tasks:param-key->id dbstruct task-params)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(handle-exceptions
exn
#f
(sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;"
task-params)))))
(define (tasks:set-state-given-param-key dbstruct param-key new-state)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key))))
(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(handle-exceptions
exn
'()
(sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE
params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
param-key state-patt action-patt test-patt)))))
(define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
- ;; (handle-exceptions
- ;; exn
- ;; '()
- ;; (sqlite3:first-row
- (let ((db (db:delay-if-busy (db:get-db dbstruct)))
- (res '()))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (cons (cons a b) res)))
- db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue
+ (db:with-db
+ dbstruct
+ #f #f
+ (lambda (dbdat db)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (cons (cons a b) res)))
+ db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue
WHERE
target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
- target run-name state-patt action-patt test-patt)
- res)) ;; )
+ target run-name state-patt action-patt test-patt)
+ res))))
;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
;;
;; do a remote call to get the task queue info but do the killing as self here.
;;
@@ -837,14 +838,20 @@
(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
; (print "Sync Steps " test-step-ids )
(let ((test-ht (hash-table-ref cached-info 'tests))
- (step-ht (hash-table-ref cached-info 'steps)))
+ (step-ht (hash-table-ref cached-info 'steps))
+ (run-id-in #f)
+ )
(for-each
(lambda (test-step-id)
- (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id))
+ (set! run-id-in (cdr test-step-id))
+ (set! test-step-id (car test-step-id))
+
+
+ (let* ((test-step-info (rmt:get-steps-info-by-id run-id-in test-step-id))
(step-id (tdb:step-get-id test-step-info))
(test-id (tdb:step-get-test_id test-step-info))
(stepname (tdb:step-get-stepname test-step-info))
(state (tdb:step-get-state test-step-info))
(status (tdb:step-get-status test-step-info))
@@ -879,14 +886,18 @@
(debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug
test-step-ids)))
(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
(let ((test-ht (hash-table-ref cached-info 'tests))
- (data-ht (hash-table-ref cached-info 'data)))
+ (data-ht (hash-table-ref cached-info 'data))
+ (run-id-in #f)
+ )
(for-each
(lambda (test-data-id)
- (let* ((test-data-info (rmt:get-data-info-by-id test-data-id))
+ (set! run-id-in (cdr test-data-id))
+ (set! test-data-id (car test-data-id))
+ (let* ((test-data-info (rmt:get-data-info-by-id run-id-in test-data-id))
(data-id (db:test-data-get-id test-data-info))
(test-id (db:test-data-get-test_id test-data-info))
(category (db:test-data-get-category test-data-info))
(variable (db:test-data-get-variable test-data-info))
(value (db:test-data-get-value test-data-info))
@@ -938,15 +949,19 @@
test-data-ids)))
(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
- (let ((test-ht (hash-table-ref cached-info 'tests)))
+ (let ((test-ht (hash-table-ref cached-info 'tests))
+ (run-id-in #f))
(for-each
(lambda (test-id)
- ; (print test-id)
- (let* ((test-info (rmt:get-test-info-by-id #f test-id))
+ (set! run-id-in (cdr test-id))
+ (set! test-id (car test-id))
+
+ (debug:print 0 *default-log-port* "test-id: " test-id " run-id: " run-id-in)
+ (let* ((test-info (rmt:get-test-info-by-id run-id-in test-id))
(run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm
(test-id (db:test-get-id test-info))
(test-name (db:test-get-testname test-info))
(item-path (db:test-get-item-path test-info))
(state (db:test-get-state test-info))
@@ -972,11 +987,11 @@
#f)))
;; "id" "run_id" "testname" "state" "status" "event_time"
;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path"
;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived"
(if (or (not item-path) (string-null? item-path))
- (debug:print-info 0 *default-log-port* "Working on Run id : " run-id "and test name : " test-name))
+ (debug:print-info 0 *default-log-port* "Working on Run id : " run-id " and test name : " test-name))
(if pgdb-run-id
(begin
(if pgdb-test-id ;; have a record
(begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
(debug:print-info 4 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id)
@@ -1031,64 +1046,69 @@
(print "In sync")
(let* ((dbh (pgdb:open configdat dbname: dest))
(area-info (pgdb:get-area-by-path dbh *toppath*))
(cached-info (make-hash-table))
(start (current-seconds))
- (test-patt (if (args:get-arg "-testpatt")
- (args:get-arg "-testpatt")
+ (test-patt (if (args:get-arg "-testpatt")
+ (args:get-arg "-testpatt")
"%"))
- (target (if (args:get-arg "-target")
- (args:get-arg "-target")
- #f))
- (run-name (if (args:get-arg "-runname")
- (args:get-arg "-runname")
- #f)))
+ (target (if (args:get-arg "-target")
+ (args:get-arg "-target")
+ #f))
+ (run-name (if (args:get-arg "-runname")
+ (args:get-arg "-runname")
+ #f)))
(if (and target (not run-name))
(begin
- (print "Error: Provide runname")
+ (print "Error: Provide runname")
(exit 1)))
(if (and (not target) run-name)
(begin
- (print "Error: Provide target")
+ (print "Error: Provide target")
(exit 1)))
;(print "123")
- ;(exit 1)
+ ;(exit 1)
(for-each (lambda (dtype)
(hash-table-set! cached-info dtype (make-hash-table)))
'(runs targets tests steps data))
(hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
(if area-info
- (let* ((last-sync-time (vector-ref area-info 3))
+ (let* ((last-sync-time (if (args:get-arg "-since") (string->number (args:get-arg "-since")) (vector-ref area-info 3)))
(smallest-last-update-time (make-hash-table))
- (changed (if (and target run-name)
+ (changed (if (and target run-name)
(rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt)
(rmt:get-changed-record-ids last-sync-time)))
(run-ids (alist-ref 'runs changed))
(test-ids (alist-ref 'tests changed))
(test-step-ids (alist-ref 'test_steps changed))
(test-data-ids (alist-ref 'test_data changed))
(run-stat-ids (alist-ref 'run_stats changed))
- (area-tag (if (args:get-arg "-area-tag")
+ (area-tag (if (args:get-arg "-area-tag")
(args:get-arg "-area-tag")
(if (args:get-arg "-area")
(args:get-arg "-area")
""))))
(if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0))))
(set! area-tag *default-area-tag*))
(if (not (equal? area-tag ""))
(task:add-area-tag dbh area-info area-tag))
- (if (or (not (null? test-ids)) (not (null? run-ids)))
- (begin
- (debug:print-info 0 *default-log-port* "syncing runs")
- (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing tests")
- (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing test steps")
- (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing test data")
- (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
- (print "----------done---------------")))
+ (if (not (null? run-ids))
+ (begin
+ (debug:print-info 0 *default-log-port* "syncing runs: " run-ids)
+ (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
+ )
+ )
+ (if (not (null? test-ids))
+ (begin
+ (debug:print-info 0 *default-log-port* "syncing tests: " test-ids)
+ (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing test steps")
+ (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing test data")
+ (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
+ )
+ )
(let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds))))
(debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time)
(if (not (and target run-name))
(if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0)))
(pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed
ADDED testlocking/justtest.scm
Index: testlocking/justtest.scm
==================================================================
--- /dev/null
+++ testlocking/justtest.scm
@@ -0,0 +1,9 @@
+(print "Starting at "(current-seconds))
+
+(dbfile:with-simple-file-lock "justtesting.lock"
+ (lambda ()
+ (print "got the lock at "(current-seconds)"!")))
+
+(print "Done at: " (current-seconds))
+(exit)
+
ADDED testlocking/testlock.sh
Index: testlocking/testlock.sh
==================================================================
--- /dev/null
+++ testlocking/testlock.sh
@@ -0,0 +1,12 @@
+#!/bin/bash
+
+HRS=$(date +%H)
+MINS=$(($(date +%M) + 1))
+if [[ $MINS -lt 10 ]];then
+ MINS="0${MINS}"
+fi
+THETIME="$HRS:$MINS"
+echo "THETIME=$THETIME"
+for x in a b c d e f g h i j;do
+ echo "megatest -load justtest.scm > $x.log" | at $THETIME
+done
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -25,19 +25,21 @@
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
+(declare (uses commonmod))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
;;(declare (uses stml2))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
+(import commonmod)
(require-library stml)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
@@ -1775,11 +1777,11 @@
))))))
;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")
(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats
- (let-values (((inp oup pid)(process "env -i PATH=$PATH dot" (list "-T" outtype))))
+ (let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype))))
(with-output-to-port oup
(lambda ()
(map print indat)))
(close-output-port oup)
(let ((res (with-input-from-port inp
@@ -1797,14 +1799,14 @@
(tests:write-dot-file testrecords dfile sizex sizey)
(if (common:file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
- (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
+ (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&"))
res)
(begin
- (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))
+ (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname))
(with-input-from-file fname
(lambda ()
(read-lines)))))))
ADDED tests/simplerun/Makefile
Index: tests/simplerun/Makefile
==================================================================
--- /dev/null
+++ tests/simplerun/Makefile
@@ -0,0 +1,5 @@
+
+cleanup :
+ killall mtest dboard -v -9 || true
+ rm -rf *.log *.bak NB* logs/* .meta .db /tmp/$(USER)/megatest_localdb/simplerun ../simpleruns/* lt
+
ADDED tests/simplerun/debug.scm
Index: tests/simplerun/debug.scm
==================================================================
--- /dev/null
+++ tests/simplerun/debug.scm
@@ -0,0 +1,61 @@
+
+(module junk
+ *
+
+(import big-chicken
+ rmtmod
+ apimod
+ dbmod
+ srfi-18
+ trace)
+
+(trace-call-sites #t)
+(trace
+ ;; db:get-tests-for-run
+ ;; rmt:general-open-connection
+ ;; rmt:open-main-connection
+ ;; rmt:drop-conn
+ ;; rmt:send-receive
+ ;; rmt:log-to-main
+ )
+
+(define (make-run-id)
+ (let* ((s (conc (current-process-id)))
+ (l (string-length s)))
+ (string->number (substring s (- l 3) l))
+ ))
+
+(define (run)
+ (let* ((th1 (make-thread
+ (lambda ()
+ (let loop ((r 0)
+ (i 1)
+ (s 0)) ;; sum
+ (let ((start-time (current-milliseconds))
+ (run-id (+ r (make-run-id))))
+ (rmt:register-test run-id "test1" (conc "item_" i))
+ (thread-sleep! 0.01)
+ (let* ((qry-time (- (current-milliseconds) start-time))
+ (tot-query-time (+ qry-time s))
+ (avg-query-time (* 1.0 (/ tot-query-time (max i 1)))))
+ (if (> qry-time 500)
+ (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time))
+ (if (eq? (modulo i 100) 0)
+ (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time))
+ (if (< i 500)
+ (loop r (+ i 1) tot-query-time)
+ (if (< r 100)
+ (let* ((start-time (current-milliseconds)))
+ (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time))
+ ;; run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode
+ (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f 0 #f))" tests for run "run-id)
+ (print "Average query time: "avg-query-time)
+ (loop (+ r 1) 0 tot-query-time))))))))
+ )))
+ (thread-start! th1)
+ (thread-join! th1)))
+
+(run)
+)
+
+
Index: tests/simplerun/megatest.config
==================================================================
--- tests/simplerun/megatest.config
+++ tests/simplerun/megatest.config
@@ -20,10 +20,14 @@
RELEASE TEXT
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50
+
+[server]
+timeout 3
+# 3600
# Uncomment this to make the in-mem db into a disk based db (slower but good for debug)
# be aware that some unit tests will fail with this due to persistent data
#
# tmpdb /tmp
@@ -35,15 +39,15 @@
[validvalues]
state start end completed
# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
-useshell yes
-launcher nbfind
+# useshell yes
+launcher nbfake
# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value
# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns
Index: tests/simplerun/tests/test1/testconfig
==================================================================
--- tests/simplerun/tests/test1/testconfig
+++ tests/simplerun/tests/test1/testconfig
@@ -24,11 +24,11 @@
[requirements]
# waiton setup
priority 0
# Iteration for your tests are controlled by the items section
-[items]
+# [items]
# PARTOFDAY morning noon afternoon evening night
# test_meta is a section for storing additional data on your test
[test_meta]
author matt
ADDED tests/simplerun/thebeginning.scm
Index: tests/simplerun/thebeginning.scm
==================================================================
--- /dev/null
+++ tests/simplerun/thebeginning.scm
@@ -0,0 +1,126 @@
+(use trace test (prefix sqlite3 sqlite3:))
+(import dbfile)
+(trace-call-sites #t)
+
+(trace
+ ;; dbfile:setup
+ ;; dbfile:open-sqlite3-db
+ ;; dbfile:init-subdb
+ ;; dbfile:add-dbdat
+ ;; db:initialize-main-db
+ ;; dbfile:set-subdb
+ ;; db:with-db
+ ;; dbfile:get-subdb
+ )
+
+(system "touch /tmp/mmgraham/megatest_localdb/simplerun/.nfs.pdx.disks.icf_gwa_001.mmgraham.fossil.megatest1.7.mod.tests.simplerun/.db/10.db")
+
+;; *************** dbfile.scm tests ****************
+
+
+;; (debug:print 0 *default-log-port* " tmp area: " (common:get-db-tmp-area))
+
+(define tmpdir (common:get-db-tmp-area))
+(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath* tmpdir)))
+(test #f #t (dbr:dbstruct? (db:setup #t)))
+(define dbstruct *dbstruct-dbs*)
+;; (test #f #t (dbr:subdb? (dbfile:init-subdb dbstruct #f db:initialize-main-db))) ;; this opens the nfs main db
+
+;; (test #f #t (dbr:dbdat? (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db))) ;; this opens the tmp db.
+;; (define maindbdat (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)) ;; this opens the tmp db.
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+
+;;(test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct #f)))
+;; (test #f #f (dbr:dbdat? (dbfile:get-dbdat dbstruct #f))) ;; stack empty so should fail.
+
+;; (test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct)))
+;; (test #f #t (stack? (dbr:subdb-dbstack (dbfile:get-subdb dbstruct #f))))
+;; (test #f '("SYSTEM" "RELEASE") (db:get-keys *dbstruct-dbs*))
+
+
+;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 1 db:initialize-main-db)))
+;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 2 db:initialize-main-db)))
+;; (define rundbdat (dbfile:open-db dbstruct 1 db:initialize-main-db))
+;; (define rundbdat2 (dbfile:open-db dbstruct 2 db:initialize-main-db))
+;; (define rundbdat3 (dbfile:open-db dbstruct 3 db:initialize-main-db))
+;; (dbfile:add-dbdat dbstruct 1 rundbdat)
+;; (dbfile:add-dbdat dbstruct 2 rundbdat2)
+;; (dbfile:add-dbdat dbstruct 3 rundbdat3)
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 1)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 1)))
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 2)))
+
+
+
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/main.db") 0))
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/1.db") 0))
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/2.db") 0))
+
+;; (test #f #t (common:simple-file-lock "./db.lock"))
+;; (test #f "./db.lock" (common:simple-file-release-lock "./db.lock"))
+
+
+
+;; *************** db.scm tests ****************
+
+
+;; (define thisdbdat (db:open-db dbstruct #f))
+;; (test #f #t (dbr:dbdat? thisdbdat))
+
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct #f)))
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 1)))
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 2)))
+
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+;; (define maindbdat (dbfile:get-dbdat dbstruct #f))
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+
+;; (define mtdbdat2 (dbr:subdb-mtdbdat (dbfile:get-subdb dbstruct #f)))
+
+;; (define areapath (dbr:dbstruct-areapath dbstruct))
+;; (define mtdbpath (dbfile:run-id->path areapath #f))
+;; (define init-proc db:initialize-main-db)
+
+;; (define mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc))
+
+;; (define maindb-handle (dbr:dbdat-dbh mtdbdat))
+;; (define maindb-handle2 (dbr:dbdat-dbh mtdbdat2))
+
+;; (sqlite3:execute maindb-handle "vacuum")
+;; (sqlite3:execute maindb-handle2 "vacuum")
+
+;; (define full-sel (conc "SELECT * from runs"))
+
+;; (sqlite3:for-each-row
+;; (lambda (a . b)
+;; (debug:print 0 *default-log-port* "a: " a " b: " b)
+;; )
+;; maindb-handle
+;; full-sel)
+
+;; (test #f #t (db:sync-touched dbstruct #f))
+;; (test #f #t (db:sync-touched dbstruct 1))
+;; (test #f #t (db:sync-touched dbstruct 2))
+
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f)))
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct (string->number "1"))))
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2)))
+
+
+;; (test #f #t (db:sync-touched dbstruct #f))
+;; (test #f #t (db:sync-touched dbstruct 1))
+;; (test #f #t (db:sync-touched dbstruct 2))
+
+
+
+(test #f #t (db:all-db-sync dbstruct))
+
+(exit)
+
+;; (test #f #t (db:close-all dbstruct))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat) (dbr:dbdat-stmt-cache rundbdat)))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat2) (dbr:dbdat-stmt-cache rundbdat2)))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh mtdbdat) (dbr:dbdat-stmt-cache mtdbdat)))
+
ADDED utils/mt-new-to-old.sh
Index: utils/mt-new-to-old.sh
==================================================================
--- /dev/null
+++ utils/mt-new-to-old.sh
@@ -0,0 +1,8 @@
+#!/bin/bash
+
+cp .megatest/main.db megatest.db
+
+for db in $(ls .megatest/?.db); do
+ echo $db
+ sqlite3 $db "SELECT * FROM tests" | sqlite3 megatest.db ".import /dev/stdin tests"
+done
ADDED utils/mt-old-to-new.sh
Index: utils/mt-old-to-new.sh
==================================================================
--- /dev/null
+++ utils/mt-old-to-new.sh
@@ -0,0 +1,41 @@
+#!/bin/bash
+if [ -d ".megatest" ]
+then
+ echo ".megatest directory present."
+ echo "You have already migrated. "
+ exit
+fi
+
+mkdir -p .megatest
+cp megatest.db .megatest/main.db
+sqlite3 .megatest/main.db << END_SQL
+delete from tests;
+delete from test_steps;
+END_SQL
+version_id=$(sqlite3 .megatest/main.db "select id from metadat where var = 'MEGATEST_VERSION'")
+current_version=$(megatest -version)
+sqlite3 .megatest/main.db "replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version')"
+
+
+sqlite3 megatest.db 'select id from runs' > runs.txt
+for run in $(cat runs.txt)
+do
+ echo "working on run id $run"
+ dbnum=$(($run%100))
+ if [ ! -f ".megatest/$dbnum.db" ]
+ then
+ dbnum=$(($run%100))
+ cp megatest.db .megatest/$dbnum.db
+ sqlite3 .megatest/$dbnum.db << END_SQL
+ delete from tests where run_id in (select id from runs where id%100!=$dbnum);
+ delete from test_data;
+ delete from test_meta;
+ delete from test_rundat;
+ delete from test_steps where not exists ( select id from tests where tests.id = test_steps.test_id);
+ replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version');
+ VACUUM;
+END_SQL
+
+ fi
+done
+
Index: utils/mt_ezstep
==================================================================
--- utils/mt_ezstep
+++ utils/mt_ezstep
@@ -31,11 +31,11 @@
exit
fi
# Since the user may not have . on the path and since we are likely to want to
# run test scripts in the current directory add the current dir to the path
-export PATH=$PATH:$PWD
+export PATH="$PATH:$PWD"
testrundir=$1; shift
stepname=$1;shift
command=$*
Index: utils/mt_xterm
==================================================================
--- utils/mt_xterm
+++ utils/mt_xterm
@@ -16,14 +16,25 @@
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
MT_TMPDISPLAY=$DISPLAY
-if [ -e megatest.sh ];then
- source megatest.sh
-fi
+MT_TMPUSER=$USER
+MT_HOME=$HOME
+
+tmpfile=`mktemp`
+
+grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile
+source $tmpfile
+rm $tmpfile
+
+# if [ -e megatest.sh ];then
+#source megatest.sh
+#fi
export DISPLAY=$MT_TMPDISPLAY
+export USER=$USER
+export HOME=$MT_HOME
if [ x"$MT_XTERM_CMD" == "x" ];then
exec xterm "$@"
else
exec $MT_XTERM_CMD
Index: utils/nbfake
==================================================================
--- utils/nbfake
+++ utils/nbfake
@@ -96,10 +96,10 @@
#======================================================================
__EOF
if [[ -z "$MY_NBFAKE_HOST" ]]; then
# Run locally
- sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &"
+ sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &"
else
# run remotely
- ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\""
+ ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\""
fi
ADDED utils/open-files.sh
Index: utils/open-files.sh
==================================================================
--- /dev/null
+++ utils/open-files.sh
@@ -0,0 +1,3 @@
+echo "Database opens: $(lsof -c mtest|egrep '.*db$'|wc -l)"
+echo "Logfile opens: $(lsof -c mtest|egrep '.*log$'|wc -l)"
+echo "TCP connections: $(lsof -c mtest|grep TCP|wc -l)"